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.42 2007/06/20 10:16:19 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 (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))) 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
 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 () 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 () event)
 307
 308 (defbinding event-peek () event)
 309
 310 (defbinding event-get-graphics-expose () event
 311   (window window))
 312
 313 (defbinding event-put () event
 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 () window
 419   (x int :out)
 420   (y int :out))
 421
 422 (defbinding window-show () nil
 423   (window window))
 424
 425 (defbinding window-show-unraised () nil
 426   (window window))
 427
 428 (defbinding window-hide () nil
 429   (window window))
 430
 431 (defbinding window-is-visible-p () boolean
 432   (window window))
 433
 434 (defbinding window-is-viewable-p () boolean
 435   (window window))
 436
 437 (defbinding window-withdraw () nil
 438   (window window))
 439
 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
 472 (defbinding window-move () nil
 473   (window window)
 474   (x int)
 475   (y int))
 476
 477 (defbinding window-resize () nil
 478   (window window)
 479   (width int)
 480   (height int))
 481
 482 (defbinding window-move-resize () nil
 483   (window window)
 484   (x int)
 485   (y int)
 486   (width int)
 487   (height int))
 488
 489 (defbinding window-scroll () nil
 490   (window window)
 491   (dx int)
 492   (dy int))
 493
 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
 501 (defbinding window-reparent () nil
 502   (window window)
 503   (new-parent window)
 504   (x int)
 505   (y int))
 506
 507 (defbinding window-clear () nil
 508   (window window))
 509
 510 (defbinding %window-clear-area () nil
 511   (window window)
 512   (x int) (y int) (width int) (height int))
 513
 514 (defbinding %window-clear-area-e () nil
 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
 520       (%window-clear-area-e window x y width height)
 521     (%window-clear-area window x y width height)))
 522
 523 (defbinding window-raise () nil
 524   (window window))
 525
 526 (defbinding window-lower () nil
 527   (window window))
 528
 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
 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))
 560
 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
 600 (defbinding window-set-user-data () nil
 601   (window window)
 602   (user-data pointer))
 603
 604 (defbinding window-set-override-redirect () nil
 605   (window window)
 606   (override-redirect-p boolean))
 607
 608 (defbinding window-set-accept-focus () nil
 609   (window window)
 610   (accept-focus-p boolean))
 611
 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
 618 ; (defbinding window-remove-filter () nil
 619
 620 ;; New code should use window-shape-combine
 621 (defbinding window-shape-combine-mask () nil
 622   (window window)
 623   (shape-mask bitmap)
 624   (offset-x int)
 625   (offset-y int))
 626
 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
 635     (null (%window-shape-combine-region window nil 0 0))
 636     (region (%window-shape-combine-region window shape offset-x offset-y))
 637     (bitmap (window-shape-combine-mask window shape offset-x offset-y))))
 638
 639 (defbinding window-set-child-shapes () nil
 640   (window window))
 641
 642 (defbinding window-merge-child-shapes () nil
 643   (window window))
 644
 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
 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))))
 664
 665   (defbinding window-set-child-input-shapes () nil
 666     (window window))
 667
 668   (defbinding window-merge-child-input-shapes () nil
 669     (window window)))
 670
 671 (defbinding window-set-static-gravities () boolean
 672   (window window)
 673   (use-static-p boolean))
 674
 675 (defbinding window-set-title () nil
 676   (window window)
 677   (title string))
 678
 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))
 687
 688 (defbinding window-set-cursor () nil
 689   (window window)
 690   (cursor (or null cursor)))
 691
 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
 702 (defbinding window-set-icon-list () nil
 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
 738 (defbinding window-get-pointer () window
 739   (window window)
 740   (x int :out)
 741   (y int :out)
 742   (mask modifier-type :out))
 743
 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
 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
 775 (defbinding %get-default-root-window () window)
 776
 777 (defun get-root-window (&optional display)
 778   (if display
 779       (error "Not implemented")
 780     (%get-default-root-window)))
 781
 782
 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
 798 ;;
 799
 800 (defbinding rgb-init () nil)
 801
 802
 803
 804
 805 ;;; Cursor
 806
 807 (defmethod allocate-foreign ((cursor cursor) &key source mask fg bg
 808                              (x 0) (y 0) (display (display-get-default)))
 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
 820     (apply #'make-instance 'cursor :source cursor args)))
 821
 822 (defbinding %cursor-new-for-display () pointer
 823   (display display)
 824   (cursor-type cursor-type))
 825
 826 (defbinding %cursor-new-from-pixmap () pointer
 827   (source pixmap)
 828   (mask bitmap)
 829   (foreground color)
 830   (background color)
 831   (x int) (y int))
 832
 833 (defbinding %cursor-new-from-pixbuf () pointer
 834   (display display)
 835   (pixbuf pixbuf)
 836   (x int) (y int))
 837
 838 (defbinding %cursor-ref () pointer
 839   (location pointer))
 840
 841 (defbinding %cursor-unref () nil
 842   (location pointer))
 843
 844
 845 ;;; Pixmaps
 846
 847 (defbinding %pixmap-new () pointer
 848   (window (or null window))
 849   (width int)
 850   (height int)
 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
 860 (defbinding %pixmap-colormap-create-from-xpm () pixmap
 861   (window (or null window))
 862   (colormap (or null colormap))
 863   (mask bitmap :out)
 864   (color (or null color))
 865   (filename pathname))
 866
 867 (defbinding %pixmap-colormap-create-from-xpm-d () pixmap
 868   (window (or null window))
 869   (colormap (or null colormap))
 870   (mask bitmap :out)
 871   (color (or null color))
 872   (data (vector string)))
 873
 874 ;; Deprecated, use pixbufs instead
 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)
 881         (etypecase source
 882           ((or string pathname)
 883            (%pixmap-colormap-create-from-xpm window colormap color  source))
 884           ((vector string)
 885            (%pixmap-colormap-create-from-xpm-d window colormap color source)))
 886       (values pixmap mask))))
 887
 888
 889 ;;; Color
 890
 891 (defbinding colormap-get-system () colormap)
 892
 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
 901   (with-memory (location #.(foreign-size (find-class 'color)))
 902     (%color-copy location)))
 903
 904 (defun %scale-value (value)
 905   (etypecase value
 906     (integer value)
 907     (float (truncate (* value 65535)))))
 908
 909 (defmethod initialize-instance ((color color) &key (red 0.0) (green 0.0) (blue 0.0))
 910   (call-next-method)
 911   (with-slots ((%red red) (%green green) (%blue blue)) color
 912     (setf
 913      %red (%scale-value red)
 914      %green (%scale-value green)
 915      %blue (%scale-value blue))))
 916
 917 (defbinding %color-parse () boolean
 918   (spec string)
 919   (color color :in/return))
 920
 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
 927 (defun ensure-color (color)
 928   (etypecase color
 929     (null nil)
 930     (color color)
 931     (string (color-parse color))
 932     (vector
 933      (make-instance 'color
 934       :red (svref color 0) :green (svref color 1) :blue (svref color 2)))))
 935
 936
 937
 938 ;;; Drawable -- all the draw- functions are deprecated and will be
 939 ;;; removed, use cairo for drawing instead.
 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
 971 (defbinding draw-line () nil
 972   (drawable drawable) (gc gc)
 973   (x1 int) (y1 int)
 974   (x2 int) (y2 int))
 975
 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
 987 (defbinding draw-rectangle () nil
 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
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))
1048
1049
1050 ;;; Key values
1051
1052 (defbinding keyval-name () 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 ;;; Cairo interaction
1077
1078 #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.8.0")
1079 (progn
1080   (defbinding cairo-create () cairo:context
1081     (drawable drawable))
1082
1083   (defmacro with-cairo-context ((cr drawable) &body body)
1084     `(let ((,cr (cairo-create ,drawable)))
1085        (unwind-protect
1086            (progn ,@body)
1087          (invalidate-instance ,cr t))))
1088
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
1103 ;;   (defbinding cairo-region () nil
1104 ;;     (cr cairo:context)
1105 ;;     (region region))
1106
1107   (defbinding (cairo-surface-get-window "clg_gdk_cairo_surface_get_window") () window
1108     (surface cairo:surface))
1109 )
1110
1111
1112
1113 ;;; Multi-threading support
1114
1115 #+sb-thread
1116 (progn
1117   (defvar *global-lock* nil)
1118
1119   (defun %global-lock-p ()
1120     (eq (car (sb-thread:mutex-value *global-lock*)) sb-thread:*current-thread*))
1121
1122   (defun threads-enter ()
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)))))
1127
1128   (defun threads-leave (&optional flush-p)
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*)))))))
1137
1138   (define-callback %enter-fn nil ()
1139     (threads-enter))
1140
1141   (define-callback %leave-fn nil ()
1142     (threads-leave))
1143
1144   (defbinding %threads-set-lock-functions (&optional) nil
1145     (%enter-fn callback)
1146     (%leave-fn callback))
1147
1148   (defun threads-init ()
1149     (%threads-set-lock-functions)
1150     (setq *global-lock* (sb-thread:make-mutex :name "global GDK lock")))
1151
1152   (defmacro with-global-lock (&body body)
1153     `(progn
1154        (threads-enter)
1155        (unwind-protect
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
1165   (defun idle-add-with-lock (function &optional (priority +priority-default-idle+))
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
1180   (defun idle-add-with-lock (funcation &optional (priority +priority-default-idle+))
1181     (idle-add function priority)))
1182
1183