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