chiark - git - mdw - clg/blob - gdk/gdk.lisp

   1 ;; Common Lisp bindings for GTK+ v2.x
   2 ;; Copyright 2000-2006 Espen S. Johnsen <espen@users.sf.net>
   3 ;;
   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:
  11 ;;
  12 ;; The above copyright notice and this permission notice shall be
  13 ;; included in all copies or substantial portions of the Software.
  14 ;;
  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
  23 ;; $Id: gdk.lisp,v 1.50 2008-04-21 16:21:07 espen Exp $
  24
  25
  26 (in-package "GDK")
  27
  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))
  34
  35
  36
  37 ;;; Display
  38
  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
  47 (defbinding %display-open () (or null display)
  48   (display-name (or null string)))
  49
  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)
  65   (let ((display (or
  66                   (%display-open name)
  67                   (error "Opening display failed: ~A" name))))
  68     (unless (display-get-default)
  69       (display-set-default display))
  70     (when (and (stringp name) (not (string= name (display-name display))))
  71       (display-add-alias display name))
  72     display))
  73
  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
 100   ((ensure-display display t) display))
 101
 102 (defbinding flush () nil)
 103
 104 (defbinding display-get-event
 105     (&optional (display (display-get-default))) (or null event)
 106   (display display))
 107
 108 (defbinding display-peek-event
 109     (&optional (display (display-get-default))) (or null 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
 117 (defbinding (display-connection-number "clg_gdk_connection_number")
 118     (&optional (display (display-get-default))) int
 119   (display display))
 120
 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=))
 133
 134 (defun ensure-display (display &optional existing-only-p)
 135   (etypecase display
 136     (null (display-get-default))
 137     (display display)
 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))))))
 148
 149
 150 ;;; Display manager
 151
 152 (defbinding display-get-default () (or null display))
 153
 154 (defbinding (display-set-default "gdk_display_manager_set_default_display")
 155     (display) nil
 156   ((display-manager) display-manager)
 157   (display display))
 158
 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
 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
 184
 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)
 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)
 239      (make-instance 'region :rectangle (ensure-rectangle region)))
 240     (list
 241      (make-instance 'region :polygon region))))
 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
 256         (map-c-vector 'list #'identity location '(inlined rectangle) length :get)
 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
 286   ((ensure-region source1) region :in/return)
 287   ((ensure-region source2) region))
 288
 289 (defbinding region-union (source1 source2) nil
 290   ((ensure-region source1) region :in/return)
 291   ((ensure-region source2) region))
 292
 293 (defbinding region-subtract (source1 source2) nil
 294   ((ensure-region source1) region :in/return)
 295   ((ensure-region source2) region))
 296
 297 (defbinding region-xor (source1 source2) nil
 298   ((ensure-region source1) region :in/return)
 299   ((ensure-region source2) region))
 300
 301
 302 ;;; Events
 303
 304 (defbinding (events-pending-p "gdk_events_pending") () boolean)
 305
 306 (defbinding event-get () (or null event))
 307
 308 (defbinding event-peek () (or null event))
 309
 310 (defbinding event-get-graphics-expose () event
 311   (window window))
 312
 313 (defbinding event-put () nil
 314   (event event))
 315
 316 ;(defbinding event-handler-set () ...)
 317
 318 (defbinding set-show-events () nil
 319   (show-events boolean))
 320
 321 (defbinding get-show-events () boolean)
 322
 323
 324 ;;; Miscellaneous functions
 325
 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))
 337
 338
 339 (defbinding pointer-grab
 340     (window &key owner-events events confine-to cursor time) grab-status
 341   (window window)
 342   (owner-events boolean)
 343   (events event-mask)
 344   (confine-to (or null window))
 345   (cursor (or null cursor))
 346   ((or time 0) (unsigned 32)))
 347
 348 (defbinding (pointer-ungrab "gdk_display_pointer_ungrab")
 349     (&optional time (display (display-get-default))) nil
 350   (display display)
 351   ((or time 0) (unsigned 32)))
 352
 353 (defbinding (pointer-is-grabbed-p "gdk_display_pointer_is_grabbed")
 354     (&optional (display (display-get-default))) boolean
 355   (display display))
 356
 357 (defbinding keyboard-grab (window &key owner-events time) grab-status
 358   (window window)
 359   (owner-events boolean)
 360   ((or time 0) (unsigned 32)))
 361
 362 (defbinding (keyboard-ungrab "gdk_display_keyboard_ungrab")
 363     (&optional time (display (display-get-default))) nil
 364   (display display)
 365   ((or time 0) (unsigned 32)))
 366
 367
 368
 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
 376
 377
 378 ;;; Visuals
 379
 380 (defbinding visual-get-best-depth () int)
 381
 382 (defbinding visual-get-best-type () visual-type)
 383
 384 (defbinding visual-get-system () visual)
 385
 386
 387 (defbinding (%visual-get-best-with-nothing "gdk_visual_get_best") () visual)
 388
 389 (defbinding %visual-get-best-with-depth () visual
 390   (depth int))
 391
 392 (defbinding %visual-get-best-with-type () visual
 393   (type visual-type))
 394
 395 (defbinding %visual-get-best-with-both () visual
 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
 406 ;(defbinding query-depths ..)
 407
 408 ;(defbinding query-visual-types ..)
 409
 410 (defbinding list-visuals () (glist visual))
 411
 412
 413 ;;; Windows
 414
 415 (defbinding window-destroy () nil
 416   (window window))
 417
 418 (defbinding (window-at-pointer "gdk_display_get_window_at_pointer")
 419     (&optional (display (display-get-default))) (or null window)
 420   display
 421   (x int :out)
 422   (y int :out))
 423
 424 (defbinding window-show () nil
 425   (window window))
 426
 427 (defbinding window-show-unraised () nil
 428   (window window))
 429
 430 (defbinding window-hide () nil
 431   (window window))
 432
 433 (defbinding window-is-visible-p () boolean
 434   (window window))
 435
 436 (defbinding window-is-viewable-p () boolean
 437   (window window))
 438
 439 (defbinding window-withdraw () nil
 440   (window window))
 441
 442 (defbinding window-iconify () nil
 443   (window window))
 444
 445 (defbinding window-deiconify () nil
 446   (window window))
 447
 448 (defbinding window-stick () nil
 449   (window window))
 450
 451 (defbinding window-unstick () nil
 452   (window window))
 453
 454 (defbinding window-maximize () nil
 455   (window window))
 456
 457 (defbinding window-unmaximize () nil
 458   (window window))
 459
 460 (defbinding window-fullscreen () nil
 461   (window window))
 462
 463 (defbinding window-unfullscreen () nil
 464   (window window))
 465
 466 (defbinding window-set-keep-above () nil
 467   (window window)
 468   (setting boolean))
 469
 470 (defbinding window-set-keep-below () nil
 471   (window window)
 472   (setting boolean))
 473
 474 (defbinding window-move () nil
 475   (window window)
 476   (x int)
 477   (y int))
 478
 479 (defbinding window-resize () nil
 480   (window window)
 481   (width int)
 482   (height int))
 483
 484 (defbinding window-move-resize () nil
 485   (window window)
 486   (x int)
 487   (y int)
 488   (width int)
 489   (height int))
 490
 491 (defbinding window-scroll () nil
 492   (window window)
 493   (dx int)
 494   (dy int))
 495
 496 #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.8.0")
 497 (defbinding window-move-region (window region dx dy) nil
 498   (window window)
 499   ((ensure-region region) region)
 500   (dx int)
 501   (dy int))
 502
 503 (defbinding window-reparent () nil
 504   (window window)
 505   (new-parent window)
 506   (x int)
 507   (y int))
 508
 509 (defbinding window-clear () nil
 510   (window window))
 511
 512 (defbinding %window-clear-area () nil
 513   (window window)
 514   (x int) (y int) (width int) (height int))
 515
 516 (defbinding %window-clear-area-e () nil
 517   (window window)
 518   (x int) (y int) (width int) (height int))
 519
 520 (defun window-clear-area (window x y width height &optional expose)
 521   (if expose
 522       (%window-clear-area-e window x y width height)
 523     (%window-clear-area window x y width height)))
 524
 525 (defbinding window-raise () nil
 526   (window window))
 527
 528 (defbinding window-lower () nil
 529   (window window))
 530
 531 (defbinding window-focus () nil
 532   (window window)
 533   (timestamp unsigned-int))
 534
 535 (defbinding window-register-dnd () nil
 536   (window window))
 537
 538 (defbinding window-begin-resize-drag () nil
 539   (window window)
 540   (edge window-edge)
 541   (button int)
 542   (root-x int)
 543   (root-y int)
 544   (timestamp unsigned-int))
 545
 546 (defbinding window-begin-move-drag () nil
 547   (window window)
 548   (button int)
 549   (root-x int)
 550   (root-y int)
 551   (timestamp unsigned-int))
 552
 553 ;; Probably not needed
 554 ;; (defbinding window-constrain-size () nil ..
 555
 556 (defbinding window-begin-paint-region (window region) nil
 557   (window window)
 558   ((ensure-region region) region))
 559
 560 (defbinding window-end-paint () nil
 561   (window window))
 562
 563 (defmacro with-window-paint ((window region) &body body)
 564   `(progn
 565      (window-begin-paint-region ,window ,region)
 566      (unwind-protect
 567          (progn ,@body)
 568        (window-end-paint ,window))))
 569
 570 ;; TODO: create wrapper function and use gdk_window_invalidate_maybe_recurse
 571 ;; if last arg is a function
 572 (defbinding window-invalidate-region (window region invalidate-children-p) nil
 573   (window window)
 574   ((ensure-region region) region)
 575   (invalidate-children-p boolean))
 576
 577 (defbinding window-get-update-area () region
 578   (window window))
 579
 580 (defbinding window-freeze-updates () nil
 581   (window window))
 582
 583 (defbinding window-thaw-updates () nil
 584   (window window))
 585
 586 (defbinding window-process-all-updates () nil)
 587
 588 (defbinding window-process-updates () nil
 589   (window window)
 590   (update-children-p boolean))
 591
 592 (defbinding window-set-debug-updates () nil
 593   (enable-p boolean))
 594
 595 (defbinding window-enable-synchronized-configure () nil
 596   (window window))
 597
 598 (defbinding window-configure-finished () nil
 599   (window window))
 600
 601 ;; Deprecated, use gobject user data mechanism
 602 (defbinding window-set-user-data () nil
 603   (window window)
 604   (user-data pointer))
 605
 606 (defbinding window-set-override-redirect () nil
 607   (window window)
 608   (override-redirect-p boolean))
 609
 610 (defbinding window-set-accept-focus () nil
 611   (window window)
 612   (accept-focus-p boolean))
 613
 614 (defbinding window-set-focus-on-map () nil
 615   (window window)
 616   (focus-on-map-p boolean))
 617
 618 ;; Added if needed
 619 ; (defbinding window-add-filter () nil
 620 ; (defbinding window-remove-filter () nil
 621
 622 ;; New code should use window-shape-combine
 623 (defbinding window-shape-combine-mask () nil
 624   (window window)
 625   (shape-mask bitmap)
 626   (offset-x int)
 627   (offset-y int))
 628
 629 (defbinding %window-shape-combine-region () nil
 630   (window window)
 631   (region (or null region))
 632   (offset-x int)
 633   (offset-y int))
 634
 635 (defun window-shape-combine (window shape offset-x offset-y)
 636   (etypecase shape
 637     (null (%window-shape-combine-region window nil 0 0))
 638     (region (%window-shape-combine-region window shape offset-x offset-y))
 639     (bitmap (window-shape-combine-mask window shape offset-x offset-y))))
 640
 641 (defbinding window-set-child-shapes () nil
 642   (window window))
 643
 644 (defbinding window-merge-child-shapes () nil
 645   (window window))
 646
 647 #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.10.0")
 648 (progn
 649   (defbinding %window-input-shape-combine-mask () nil
 650     (window window)
 651     (shape-mask bitmap)
 652     (x int)
 653     (y int))
 654
 655   (defbinding %window-input-shape-combine-region () nil
 656     (window window)
 657     (region (or null region))
 658     (x int)
 659     (y int))
 660
 661   (defun window-input-shape-combine (window shape x y)
 662     (etypecase shape
 663       (null (%window-input-shape-combine-region window nil 0 0))
 664       (region (%window-input-shape-combine-region window shape x y))
 665       (bitmap (%window-input-shape-combine-mask window shape x y))))
 666
 667   (defbinding window-set-child-input-shapes () nil
 668     (window window))
 669
 670   (defbinding window-merge-child-input-shapes () nil
 671     (window window)))
 672
 673 (defbinding window-set-static-gravities () boolean
 674   (window window)
 675   (use-static-p boolean))
 676
 677 (defbinding window-set-title () nil
 678   (window window)
 679   (title string))
 680
 681 (defbinding window-set-background () nil
 682   (window window)
 683   (color color))
 684
 685 (defbinding window-set-back-pixmap (window pixmap &optional parent-relative-p) nil
 686   (window window)
 687   (pixmap (or null pixmap))
 688   (parent-relative-p boolean))
 689
 690 (defbinding window-set-cursor () nil
 691   (window window)
 692   (cursor (or null cursor)))
 693
 694 (defbinding window-get-geometry () nil
 695   (window window)
 696   (x int :out)
 697   (y int :out)
 698   (width int :out)
 699   (height int :out)
 700   (depth int :out))
 701
 702 ;(defbinding window-set-geometry-hints () nil
 703
 704 (defbinding window-set-icon-list () nil
 705   (window window)
 706   (icons (glist pixbufs)))
 707
 708 (defbinding window-set-skip-taskbar-hint () nil
 709   (window window)
 710   (skip-taskbar-p boolean))
 711
 712 (defbinding window-set-skip-pager-hint () nil
 713   (window window)
 714   (skip-pager-p boolean))
 715
 716 #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.8.0")
 717 (defbinding window-set-urgency-hint () nil
 718   (window window)
 719   (urgent-p boolean))
 720
 721 (defbinding window-get-position () nil
 722   (window window)
 723   (x int :out)
 724   (y int :out))
 725
 726 (defbinding window-get-root-origin () nil
 727   (window window)
 728   (x int :out)
 729   (y int :out))
 730
 731 (defbinding window-get-frame-extents (window &optional (extents (make-instance 'rect))) nil
 732   (window window)
 733   (extents rectangle :in/return))
 734
 735 (defbinding window-get-origin () nil ; this may not work as
 736   (window window)                    ; an int is actually returned
 737   (x int :out)
 738   (y int :out))
 739
 740 (defbinding window-get-pointer () (or null window)
 741   (window window)
 742   (x int :out)
 743   (y int :out)
 744   (mask modifier-type :out))
 745
 746 ;(defbinding window-set-icon () nil
 747
 748 (defbinding window-set-icon-name () nil
 749   (window window)
 750   (icon-name string))
 751
 752 (defbinding window-set-transient-for () nil
 753   (window window)
 754   (parent window))
 755
 756 (defbinding window-set-role () nil
 757   (window window)
 758   (role string))
 759
 760 (defbinding %window-get-decorations () boolean
 761   (window window)
 762   (decorations wm-decoration :out))
 763
 764 (defun %window-decorations-getter (window)
 765   (nth-value 1 (%window-get-decorations window)))
 766
 767 (defun %window-decorations-boundp (window)
 768   (%window-get-decorations window))
 769
 770 (defbinding %window-get-toplevels () (glist window))
 771
 772 (defun window-get-toplevels (&optional screen)
 773   (if screen
 774       (error "Not implemented")
 775     (%window-get-toplevels)))
 776
 777 (defbinding %get-default-root-window () window)
 778
 779 (defun get-root-window (&optional display)
 780   (if display
 781       (error "Not implemented")
 782     (%get-default-root-window)))
 783
 784
 785
 786 ;;; Drag and Drop
 787
 788 ;; Destination side
 789
 790 (defbinding drag-status () nil
 791   (context drag-context)
 792   (action drag-action)
 793   (time (unsigned 32)))
 794
 795
 796
 797
 798
 799
 800 ;;
 801
 802 (defbinding rgb-init () nil)
 803
 804
 805
 806
 807 ;;; Cursor
 808
 809 (defmethod allocate-foreign ((cursor cursor) &key source mask fg bg
 810                              (x 0) (y 0) (display (display-get-default)))
 811   (etypecase source
 812     (keyword (%cursor-new-for-display display source))
 813     (pixbuf (%cursor-new-from-pixbuf display source x y))
 814     (pixmap (%cursor-new-from-pixmap source mask
 815              (or fg (ensure-color #(0.0 0.0 0.0)))
 816              (or bg (ensure-color #(1.0 1.0 1.0))) x y))
 817     (pathname (%cursor-new-from-pixbuf display (pixbuf-load source) x y))))
 818
 819 (defun ensure-cursor (cursor &rest args)
 820   (if (typep cursor 'cursor)
 821       cursor
 822     (apply #'make-instance 'cursor :source cursor args)))
 823
 824 (defbinding %cursor-new-for-display () pointer
 825   (display display)
 826   (cursor-type cursor-type))
 827
 828 (defbinding %cursor-new-from-pixmap () pointer
 829   (source pixmap)
 830   (mask bitmap)
 831   (foreground color)
 832   (background color)
 833   (x int) (y int))
 834
 835 (defbinding %cursor-new-from-pixbuf () pointer
 836   (display display)
 837   (pixbuf pixbuf)
 838   (x int) (y int))
 839
 840 (defbinding %cursor-ref () pointer
 841   (location pointer))
 842
 843 (defbinding %cursor-unref () nil
 844   (location pointer))
 845
 846
 847 ;;; Pixmaps
 848
 849 (defbinding %pixmap-new () pointer
 850   (window (or null window))
 851   (width int)
 852   (height int)
 853   (depth int))
 854
 855 (defmethod allocate-foreign ((pximap pixmap) &key width height depth window)
 856   (%pixmap-new window (or width (drawable-width window)) (or height (drawable-height window)) (or depth -1)))
 857
 858 (defun pixmap-new (width height depth &key window)
 859   (warn "PIXMAP-NEW is deprecated, use (make-instance 'pixmap ...) instead")
 860   (make-instance 'pixmap :width width :height height :depth depth :window window))
 861
 862 (defbinding %pixmap-colormap-create-from-xpm () pixmap
 863   (window (or null window))
 864   (colormap (or null colormap))
 865   (mask bitmap :out)
 866   (color (or null color))
 867   (filename pathname))
 868
 869 (defbinding %pixmap-colormap-create-from-xpm-d () pixmap
 870   (window (or null window))
 871   (colormap (or null colormap))
 872   (mask bitmap :out)
 873   (color (or null color))
 874   (data (vector string)))
 875
 876 ;; Deprecated, use pixbufs instead
 877 (defun pixmap-create (source &key color window colormap)
 878   (let ((window
 879          (if (not (or window colormap))
 880              (get-root-window)
 881            window)))
 882     (multiple-value-bind (pixmap mask)
 883         (etypecase source
 884           ((or string pathname)
 885            (%pixmap-colormap-create-from-xpm window colormap color  source))
 886           ((vector string)
 887            (%pixmap-colormap-create-from-xpm-d window colormap color source)))
 888       (values pixmap mask))))
 889
 890
 891 ;;; Color
 892
 893 (defbinding colormap-get-system () colormap)
 894
 895 (defbinding %color-copy () pointer
 896   (location pointer))
 897
 898 (defmethod allocate-foreign ((color color)  &rest initargs)
 899   (declare (ignore color initargs))
 900   ;; Color structs are allocated as memory chunks by gdk, and since
 901   ;; there is no gdk_color_new we have to use this hack to get a new
 902   ;; color chunk
 903   (with-memory (location #.(foreign-size (find-class 'color)))
 904     (%color-copy location)))
 905
 906 (defun %scale-value (value)
 907   (etypecase value
 908     (integer value)
 909     (float (truncate (* value 65535)))))
 910
 911 (defmethod initialize-instance ((color color) &key (red 0.0) (green 0.0) (blue 0.0))
 912   (call-next-method)
 913   (with-slots ((%red red) (%green green) (%blue blue)) color
 914     (setf
 915      %red (%scale-value red)
 916      %green (%scale-value green)
 917      %blue (%scale-value blue))))
 918
 919 (defbinding %color-parse () boolean
 920   (spec string)
 921   (color color :in/return))
 922
 923 (defun color-parse (spec &optional (color (make-instance 'color)))
 924   (multiple-value-bind (succeeded-p color) (%color-parse spec color)
 925     (if succeeded-p
 926         color
 927       (error "Parsing color specification ~S failed." spec))))
 928
 929 (defun ensure-color (color)
 930   (etypecase color
 931     (null nil)
 932     (color color)
 933     (string (color-parse color))
 934     (vector
 935      (make-instance 'color
 936       :red (svref color 0) :green (svref color 1) :blue (svref color 2)))))
 937
 938
 939
 940 ;;; Drawable -- all the draw- functions are deprecated and will be
 941 ;;; removed, use cairo for drawing instead.
 942
 943 (defbinding drawable-get-size () nil
 944   (drawable drawable)
 945   (width int :out)
 946   (height int :out))
 947
 948 (defbinding (drawable-width "gdk_drawable_get_size") () nil
 949   (drawable drawable)
 950   (width int :out)
 951   (nil null))
 952
 953 (defbinding (drawable-height "gdk_drawable_get_size") () nil
 954   (drawable drawable)
 955   (nil null)
 956   (height int :out))
 957
 958 ;; (defbinding drawable-get-clip-region () region
 959 ;;   (drawable drawable))
 960
 961 ;; (defbinding drawable-get-visible-region () region
 962 ;;   (drawable drawable))
 963
 964 (defbinding draw-point () nil
 965   (drawable drawable) (gc gc)
 966   (x int) (y int))
 967
 968 (defbinding %draw-points () nil
 969   (drawable drawable) (gc gc)
 970   (points pointer)
 971   (n-points int))
 972
 973 (defbinding draw-line () nil
 974   (drawable drawable) (gc gc)
 975   (x1 int) (y1 int)
 976   (x2 int) (y2 int))
 977
 978 (defbinding draw-pixbuf
 979     (drawable gc pixbuf src-x src-y dest-x dest-y &optional
 980      width height (dither :none) (x-dither 0) (y-dither 0)) nil
 981   (drawable drawable) (gc (or null gc))
 982   (pixbuf pixbuf)
 983   (src-x int) (src-y int)
 984   (dest-x int) (dest-y int)
 985   ((or width -1) int) ((or height -1) int)
 986   (dither rgb-dither)
 987   (x-dither int) (y-dither int))
 988
 989 (defbinding draw-rectangle () nil
 990   (drawable drawable) (gc gc)
 991   (filled boolean)
 992   (x int) (y int)
 993   (width int) (height int))
 994
 995 (defbinding draw-arc () nil
 996   (drawable drawable) (gc gc)
 997   (filled boolean)
 998   (x int) (y int)
 999   (width int) (height int)
1000   (angle1 int) (angle2 int))
1001
1002 (defbinding %draw-layout () nil
1003   (drawable drawable) (gc gc)
1004   (x int) (y int)
1005   (layout pango:layout))
1006
1007 (defbinding %draw-layout-with-colors () nil
1008   (drawable drawable) (gc gc)
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 x y layout &optional foreground background)
1015   (if (or foreground background)
1016       (%draw-layout-with-colors drawable gc x y layout foreground background)
1017     (%draw-layout drawable gc 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))
1048
1049
1050 ;;; Key values
1051
1052 (defbinding keyval-name () (static string)
1053   (keyval unsigned-int))
1054
1055 (defbinding %keyval-from-name () unsigned-int
1056   (name string))
1057
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
1064 (defbinding keyval-to-upper () unsigned-int
1065   (keyval unsigned-int))
1066
1067 (defbinding keyval-to-lower () unsigned-int
1068   (keyval unsigned-int))
1069
1070 (defbinding (keyval-is-upper-p "gdk_keyval_is_upper") () boolean
1071   (keyval unsigned-int))
1072
1073 (defbinding (keyval-is-lower-p "gdk_keyval_is_lower") () boolean
1074   (keyval unsigned-int))
1075
1076
1077 ;;; Cairo interaction
1078
1079 #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.8.0")
1080 (progn
1081   (defbinding cairo-create () cairo:context
1082     (drawable drawable))
1083
1084   (defmacro with-cairo-context ((cr drawable) &body body)
1085     `(let ((,cr (cairo-create ,drawable)))
1086        (unwind-protect
1087            (progn ,@body)
1088          (invalidate-instance ,cr t))))
1089
1090   (defbinding cairo-set-source-color () nil
1091     (cr cairo:context)
1092     (color color))
1093
1094   (defbinding cairo-set-source-pixbuf (cr pixbuf &optional (x 0.0) (y 0.0)) nil
1095     (cr cairo:context)
1096     (pixbuf pixbuf)
1097     (x double-float)
1098     (y double-float))
1099
1100   (defbinding cairo-set-source-pixmap (cr pixmap &optional (x 0.0) (y 0.0)) nil
1101     (cr cairo:context)
1102     (pixmap pixmap)
1103     (x double-float)
1104     (y double-float))
1105
1106   (defbinding cairo-rectangle () nil
1107     (cr cairo:context)
1108     (rectangle rectangle))
1109
1110   (defbinding cairo-region (cr region) nil
1111     (cr cairo:context)
1112     ((ensure-region region) region))
1113
1114   (defbinding (cairo-surface-get-window "clg_gdk_cairo_surface_get_window") () window
1115     (surface cairo:surface))
1116 )
1117
1118
1119
1120 ;;; Multi-threading support
1121
1122 #+sb-thread
1123 (progn
1124   (defvar *global-lock* nil)
1125   (defvar *recursion-count* 0)
1126
1127   (defun %global-lock-p ()
1128     (eq (sb-thread:mutex-value *global-lock*) sb-thread:*current-thread*))
1129
1130   (defun threads-enter ()
1131     (when *global-lock*
1132       (if (%global-lock-p)
1133           (incf *recursion-count*)
1134         (sb-thread:get-mutex *global-lock*))))
1135
1136   (defun threads-leave (&optional flush-p)
1137     (when *global-lock*
1138       (assert (%global-lock-p))
1139       (cond
1140        ((zerop *recursion-count*)
1141         (when flush-p
1142           (flush))
1143         (sb-thread:release-mutex *global-lock*))
1144        (t (decf *recursion-count*)))))
1145
1146   (define-callback %enter-fn nil ()
1147     (threads-enter))
1148
1149   (define-callback %leave-fn nil ()
1150     (threads-leave))
1151
1152   (defbinding %threads-set-lock-functions (nil) nil
1153     (%enter-fn callback)
1154     (%leave-fn callback))
1155
1156   (defun threads-init ()
1157     (setq *global-lock* (sb-thread:make-mutex :name "global GDK lock"))
1158     (%threads-set-lock-functions))
1159
1160   (defmacro with-global-lock (&body body)
1161     `(progn
1162        (threads-enter)
1163        (unwind-protect
1164            (progn ,@body)
1165          (threads-leave t))))
1166
1167   (defun timeout-add-with-lock (interval function &optional (priority +priority-default+))
1168     (timeout-add interval
1169      #'(lambda ()
1170          (with-global-lock (funcall function)))
1171      priority))
1172
1173   (defun idle-add-with-lock (function &optional (priority +priority-default-idle+))
1174     (idle-add
1175      #'(lambda ()
1176          (with-global-lock (funcall function)))
1177      priority)))
1178
1179
1180 #-sb-thread
1181 (progn
1182   (defmacro with-global-lock (&body body)
1183     `(progn ,@body))
1184
1185   (defun timeout-add-with-lock (interval function &optional (priority +priority-default+))
1186     (timeout-add interval function priority))
1187
1188   (defun idle-add-with-lock (function &optional (priority +priority-default-idle+))
1189     (idle-add function priority)))
1190
1191