gtk/gtk.widget.lisp

   1 (in-package :gtk)
   2
   3 ; TODO: GtkWidget
   4
   5 (define-g-boxed-cstruct selection-data "GtkSelectionData"
   6   (selection gdk-atom-as-string :initform nil)
   7   (target gdk-atom-as-string :initform nil)
   8   (type gdk-atom-as-string :initform nil)
   9   (format :int :initform 0)
  10   (data :pointer :initform (null-pointer))
  11   (length :int :initform 0)
  12   (display (g-object display) :initform nil))
  13
  14 (export (boxed-related-symbols 'selection-data))
  15
  16 (defun widget-flags (widget)
  17   (convert-from-foreign (gtk-object-flags-as-integer widget) 'widget-flags))
  18
  19 (defun (setf widget-flags) (new-value widget)
  20   (setf (gtk-object-flags-as-integer widget)
  21         (convert-to-foreign new-value 'widget-flags))
  22   new-value)
  23
  24 (export 'widget-flags)
  25
  26 (defcstruct %gtk-widget
  27   (:object %gtk-object)
  28   (:private-flags :uint16)
  29   (:state :uint8)
  30   (:saved-state :uint8)
  31   (:name (:pointer :char))
  32   (:style :pointer)
  33   (:requisition requisition-cstruct)
  34   (:allocation allocation-cstruct)
  35   (:window :pointer)
  36   (:parent :pointer))
  37
  38 (defun widget-state (widget)
  39   (convert-from-foreign (foreign-slot-value (pointer widget) '%gtk-widget :state) 'state-type))
  40
  41 (export 'widget-state)
  42
  43 (defun widget-saved-state (widget)
  44   (convert-from-foreign (foreign-slot-value (pointer widget) '%gtk-widget :saved-state) 'state-type))
  45
  46 (export 'widget-saved-state)
  47
  48 (defmacro widget-p-fn (type)
  49   (let ((name (intern (format nil "WIDGET-~A-P" (symbol-name type)) (find-package :gtk))))
  50     `(progn (defun ,name (widget)
  51               (member ,type (widget-flags widget)))
  52             (export ',name))))
  53
  54 (widget-p-fn :toplevel)
  55 (widget-p-fn :no-window)
  56 (widget-p-fn :realized)
  57 (widget-p-fn :mapped)
  58 (widget-p-fn :visible)
  59 (widget-p-fn :sensitive)
  60 (widget-p-fn :parent-sensitive)
  61 (widget-p-fn :can-focus)
  62 (widget-p-fn :has-focus)
  63 (widget-p-fn :can-default)
  64 (widget-p-fn :has-default)
  65 (widget-p-fn :has-grab)
  66 (widget-p-fn :rc-style)
  67 (widget-p-fn :composite-child)
  68 (widget-p-fn :no-reparent)
  69 (widget-p-fn :app-paintable)
  70 (widget-p-fn :receives-default)
  71 (widget-p-fn :double-buffered)
  72 (widget-p-fn :no-show-all)
  73
  74 (defcfun (widget-unparent "gtk_widget_unparent") :void
  75   (widget g-object))
  76
  77 (export 'widget-unparent)
  78
  79 (defcfun gtk-widget-show :void
  80   (widget g-object))
  81
  82 (defcfun gtk-widget-show-all :void
  83   (widget g-object))
  84
  85 (defun widget-show (widget &key (all t))
  86   (if all
  87       (gtk-widget-show-all widget)
  88       (gtk-widget-show widget)))
  89
  90 (export 'widget-show)
  91
  92 (defcfun (widget-show-now "gtk_widget_show_now") :void
  93   (widget g-object))
  94
  95 (export 'widget-show-now)
  96
  97 (defcfun gtk-widget-hide :void
  98   (widget g-object))
  99
 100 (defcfun gtk-widget-hide-all :void
 101   (widget g-object))
 102
 103 (defun widget-hide (widget &key (all t))
 104   (if all
 105       (gtk-widget-hide-all widget)
 106       (gtk-widget-hide widget)))
 107
 108 (export 'widget-hide)
 109
 110 (defcfun (widget-map "gtk_widget_map") :void
 111   (widget g-object))
 112
 113 (export 'widget-map)
 114
 115 (defcfun (widget-unmap "gtk_widget_unmap") :void
 116   (widget g-object))
 117
 118 (export 'widget-unmap)
 119
 120 (defcfun (widget-realize "gtk_widget_realize") :void
 121   (width g-object))
 122
 123 (export 'widget-realize)
 124
 125 (defcfun (widget-unrealize "gtk_widget_unrealize") :void
 126   (width g-object))
 127
 128 (export 'widget-unrealize)
 129
 130 (defcfun (widget-queue-draw "gtk_widget_queue_draw") :void
 131   (widget (g-object widget)))
 132
 133 (export 'widget-queue-draw)
 134
 135 (defcfun (widget-queue-resize "gtk_widget_queue_resize") :void
 136   (widget (g-object widget)))
 137
 138 (export 'widget-queue-resize)
 139
 140 (defcfun (widget-queue-resize-no-redraw "gtk_widget_queue_resize_no_redraw") :void
 141   (widget (g-object widget)))
 142
 143 (export 'widget-queue-resize-no-redraw)
 144
 145 ; TODO: gtk_widget_get_child_requisition
 146
 147 ; TODO: gtk_widget_size_allocate
 148
 149 (defcfun (widget-add-accelerator "gtk_widget_add_accelerator") :void
 150   (widget g-object)
 151   (accel-signal :string)
 152   (accel-group g-object)
 153   (accel-key :uint)
 154   (accel-mods modifier-type)
 155   (accel-flags accel-flags))
 156
 157 (export 'widget-add-accelerator)
 158
 159 (defcfun (widget-remove-accelerator "gtk_widget_remove_accelerator") :void
 160   (widget g-object)
 161   (accel-group g-object)
 162   (accel-key :uint)
 163   (accel-mods modifier-type))
 164
 165 (export 'widget-remove-accelerator)
 166
 167 (defcfun (widget-set-accel-path "gtk_widget_set_accel_path") :void
 168   (widget g-object)
 169   (accel-path :string)
 170   (accel-group g-object))
 171
 172 (export 'widget-set-accel-path)
 173
 174 ; TODO: gtk_widget_list_accel_closures
 175
 176 (defcfun gtk-widget-can-activate-accel :boolean
 177   (widget g-object)
 178   (signal-id :uint))
 179
 180 (defun widget-can-activate-accel (widget signal)
 181   (when (stringp signal) (setf signal (g-signal-lookup signal (g-type-from-object widget))))
 182   (gtk-widget-can-activate-accel widget signal))
 183
 184 (export 'widget-can-activate-accel)
 185
 186 (defcfun (widget-event "gtk_widget_event") :boolean
 187   (widget (g-object widget))
 188   (event (g-boxed-foreign event)))
 189
 190 (export 'widget-event)
 191
 192 (defcfun (widget-activate "gtk_widget_activate") :boolean
 193   (widget g-object))
 194
 195 (export 'widget-activate)
 196
 197 (defcfun (widget-reparent "gtk_widget_reparent") :void
 198   (widget g-object)
 199   (new-parent g-object))
 200
 201 (export 'widget-reparent)
 202
 203 (defcfun gtk-widget-intersect :boolean
 204   (widget g-object)
 205   (area (g-boxed-foreign rectangle))
 206   (intersection (g-boxed-foreign rectangle)))
 207
 208 (defun widget-intersect (widget rectangle)
 209   (let ((result (make-rectangle)))
 210     (when (gtk-widget-intersect widget rectangle result)
 211       result)))
 212
 213 (export 'widget-intersect)
 214
 215 (defcfun (widget-focus-p "gtk_widget_is_focus") :boolean
 216   (widget g-object))
 217
 218 (export 'widget-focus-p)
 219
 220 (defcfun (widget-grab-focus "gtk_widget_grab_focus") :void
 221   (widget g-object))
 222
 223 (export 'widget-grab-focus)
 224
 225 (defcfun (widget-grab-default "gtk_widget_grab_default") :void
 226   (widget g-object))
 227
 228 (export 'widget-grab-default)
 229
 230 (defcfun (widget-set-state "gtk_widget_set_state") :void
 231   (widget (g-object widget))
 232   (state state-type))
 233
 234 (export 'widget-set-state)
 235
 236 (defcfun (widget-ancestor "gtk_widget_get_ancestor") (g-object widget)
 237   (widget (g-object widget))
 238   (type g-type-designator))
 239
 240 (export 'widget-ancestor)
 241
 242 (defcfun gtk-widget-get-pointer :void
 243   (widget g-object)
 244   (x (:pointer :int))
 245   (y (:pointer :int)))
 246
 247 (defun widget-pointer (widget)
 248   (with-foreign-objects ((x :int) (y :int))
 249     (gtk-widget-get-pointer widget x y)
 250     (values (mem-ref x :int) (mem-ref y :int))))
 251
 252 (export 'widget-pointer)
 253
 254 (defcfun (widget-is-ancestor "gtk_widget_is_ancestor") :boolean
 255   (widget g-object)
 256   (container g-object))
 257
 258 (export 'widget-is-ancestor)
 259
 260 (defcfun gtk-widget-translate-coordinates :boolean
 261   (src-widget g-object)
 262   (dst-widget g-object)
 263   (src-x :int)
 264   (src-y :int)
 265   (dst-x (:pointer :int))
 266   (dst-y (:pointer :int)))
 267
 268 (defun widget-translate-coordinates (src-widget dst-widget src-x src-y)
 269   (with-foreign-objects ((dst-x :int) (dst-y :int))
 270     (gtk-widget-translate-coordinates src-widget dst-widget src-x src-y dst-x dst-y)
 271     (values (mem-ref dst-x :int)
 272             (mem-ref dst-y :int))))
 273
 274 (export 'widget-translate-coordinates)
 275
 276 (defcfun (widget-ensure-style "gtk_widget_ensure_style") :void
 277   (widget g-object))
 278
 279 (export 'widget-ensure-style)
 280
 281 (defcfun (widget-reset-rc-styles "gtk_widget_reset_rc_styles") :void
 282   (widget g-object))
 283
 284 (export 'widget-reset-rc-styles)
 285
 286 (defcfun (widget-push-colormap "gtk_widget_push_colormap") :void
 287   (colormap (g-object gdk-colormap)))
 288
 289 (export 'widget-push-colormap)
 290
 291 (defcfun (widget-pop-colormap "gtk_widget_pop_colormap") :void)
 292
 293 (export 'widget-pop-colormap)
 294
 295 (defcfun (widget-default-colormap "gtk_widget_get_default_colormap") (g-object gdk-colormap))
 296
 297 (defcfun gtk-widget-set-default-colormap :void
 298   (colormap (g-object gdk-colormap)))
 299
 300 (defun (setf widget-default-colormap) (colormap)
 301   (gtk-widget-set-default-colormap colormap))
 302
 303 (export 'widget-default-colormap)
 304
 305 (defcfun (widget-default-style "gtk_widget_get_default_style") (g-object style))
 306
 307 (export 'widget-default-style)
 308
 309 (defcfun (widget-default-visual "gtk_widget_get_default_visual") (g-object visual))
 310
 311 (export 'widget-default-visual)
 312
 313 (defcfun (widget-default-direction "gtk_widget_get_default_direction") text-direction)
 314
 315 (defcfun gtk-widget-set-default-direction :void
 316   (direction text-direction))
 317
 318 (defun (setf widget-default-direction) (new-value)
 319   (gtk-widget-set-default-direction new-value))
 320
 321 (export 'widget-default-direction)
 322
 323 (defcfun (widget-shape-combine-mask "gtk_widget_shape_combine_mask") :void
 324   (widget (g-object widget))
 325   (shape-mask g-object)
 326   (offset-x :int)
 327   (offset-y :int))
 328
 329 (export 'widget-shape-combine-mask)
 330
 331 (defcfun (widget-input-shape-combine-mask "gtk_widget_input_shape_combine_mask") :void
 332   (widget (g-object widget))
 333   (shape-mask g-object)
 334   (offset-x :int)
 335   (offset-y :int))
 336
 337 (export 'widget-input-shape-combine-mask)
 338
 339 (defcfun gtk-widget-path :void
 340   (widget g-object)
 341   (path-length (:pointer :uint))
 342   (path (:pointer (:pointer :char)))
 343   (path-reversed (:pointer (:pointer :char))))
 344
 345 (defcfun gtk-widget-class-path :void
 346   (widget g-object)
 347   (path-length (:pointer :uint))
 348   (path (:pointer (:pointer :char)))
 349   (path-reversed (:pointer (:pointer :char))))
 350
 351 (defun widget-path (widget &key (path-type :name))
 352   (assert (typep path-type '(member :name :class)))
 353   (with-foreign-object (path :pointer)
 354     (ecase path-type
 355       (:name (gtk-widget-path widget (null-pointer) path (null-pointer)))
 356       (:class (gtk-widget-class-path widget (null-pointer) path (null-pointer))))
 357     (mem-ref path '(g-string :free-from-foreign t))))
 358
 359 (export 'widget-path)
 360
 361 (defcfun (widget-modify-fg "gtk_widget_modify_fg") :void
 362   (widget (g-object widget))
 363   (state state-type)
 364   (color (g-boxed-foreign color)))
 365
 366 (export 'widget-modify-fg)
 367
 368 (defcfun (widget-modify-bg "gtk_widget_modify_bg") :void
 369   (widget (g-object widget))
 370   (state state-type)
 371   (color (g-boxed-foreign color)))
 372
 373 (export 'widget-modify-bg)
 374
 375 (defcfun (widget-modify-text "gtk_widget_modify_text") :void
 376   (widget (g-object widget))
 377   (state state-type)
 378   (color (g-boxed-foreign color)))
 379
 380 (export 'widget-modify-text)
 381
 382 (defcfun (widget-modify-base "gtk_widget_modify_base") :void
 383   (widget (g-object widget))
 384   (state state-type)
 385   (color (g-boxed-foreign color)))
 386
 387 (export 'widget-modify-base)
 388
 389 ;void                gtk_widget_modify_font              (GtkWidget *widget,
 390 ;                                                         PangoFontDescription *font_desc);
 391
 392 (defcfun (widget-modify-cursor "gtk_widget_modify_cursor") :void
 393   (widget (g-object widget))
 394   (primary (g-boxed-foreign color))
 395   (secondary (g-boxed-foreign color)))
 396
 397 (export 'widget-modify-cursor)
 398
 399 (defcfun (widget-create-pango-context "gtk_widget_create_pango_context") (g-object :already-referenced)
 400   (widget g-object))
 401
 402 (export 'widget-create-pango-context)
 403
 404 (defcfun (widget-create-pango-layout "gtk_widget_create_pango_layout") (g-object pango-layout :already-referenced)
 405   (widget (g-object widget))
 406   (text :string))
 407
 408 (export 'widget-create-pango-layout)
 409
 410 (defcfun (widget-render-icon "gtk_widget_render_icon") g-object
 411   (widget g-object)
 412   (stock-id :string)
 413   (size icon-size)
 414   (detail :string))
 415
 416 (export 'widget-render-icon)
 417
 418 (defcfun (widget-push-composite-child "gtk_widget_push_composite_child") :void
 419   (widget g-object))
 420
 421 (export 'widget-push-composite-child)
 422
 423 (defcfun (widget-pop-composite-child "gtk_widget_pop_composite_child") :void
 424   (widget g-object))
 425
 426 (export 'widget-pop-composite-child)
 427
 428 (defcfun (widget-queue-clear "gtk_widget_queue_clear") :void
 429   (widget (g-object widget)))
 430
 431 (export 'widget-queue-clear)
 432
 433 (defcfun (widget-queue-clear-area "gtk_widget_queue_clear_area") :void
 434   (widget (g-object widget))
 435   (x :int)
 436   (y :int)
 437   (width :int)
 438   (height :int))
 439
 440 (export 'widget-queue-clear-area)
 441
 442 (defcfun (widget-queue-draw-area "gtk_widget_queue_draw_area") :void
 443   (widget g-object)
 444   (x :int)
 445   (y :int)
 446   (width :int)
 447   (height :int))
 448
 449 (export 'widget-queue-draw-area)
 450
 451 (defcfun (widget-reset-shapes "gtk_widget_reset_shapes") :void
 452   (widget g-object))
 453
 454 (export 'widget-reset-shapes)
 455
 456 (defcfun (widget-set-double-buffered "gtk_widget_set_double_buffered") :void
 457   (widget (g-object widget))
 458   (double-buffered :boolean))
 459
 460 (export 'widget-set-double-buffered)
 461
 462 (defcfun (widget-set-scroll-adjustments "gtk_widget_set_scroll_adjustments") :boolean
 463   (widget g-object)
 464   (hadjustment g-object)
 465   (vadjustment g-object))
 466
 467 (export 'widget-set-scroll-adjustments)
 468
 469 (defcfun (widget-mnemonic-activate "gtk_widget_mnemonic_activate") :boolean
 470   (widget (g-object widget))
 471   (group-cycling :boolean))
 472
 473 (export 'widget-mnemonic-activate)
 474
 475 ; TODO: gtk_widget_class_install_style_property
 476
 477 ; TOOD: gtk_widget_class_install_style_property_parser
 478
 479 ; TODO: gtk_widget_class_list_style_properties
 480
 481 (defcfun (widget-region-intersect "gtk_widget_region_intersect") (g-boxed-foreign region :return)
 482   (widget (g-object widget))
 483   (region (g-boxed-foreign region)))
 484
 485 (export 'widget-region-intersect)
 486
 487 ; ignored: gtk_widget_send_expose
 488
 489 (defcfun gtk-widget-style-get-property :void
 490   (widget g-object)
 491   (property-name :string)
 492   (value (:pointer g-value)))
 493
 494 (defcfun gtk-widget-class-find-style-property (:pointer g-param-spec)
 495   (class :pointer)
 496   (property-name :string))
 497
 498 (defcfun gtk-widget-class-list-style-properties (:pointer (:pointer g-param-spec))
 499   (class :pointer)
 500   (n-properties (:pointer :int)))
 501
 502 (defun widget-get-style-properties (type)
 503   (setf type (gtype type))
 504   (let ((class (g-type-class-ref type)))
 505     (unwind-protect
 506          (with-foreign-object (np :int)
 507            (let ((specs (gtk-widget-class-list-style-properties class np)))
 508              (unwind-protect
 509                   (loop
 510                      repeat (mem-ref np :int)
 511                      for i from 0
 512                      for spec = (mem-aref specs :pointer i)
 513                      collect (parse-g-param-spec spec))
 514                (g-free specs))))
 515       (g-type-class-unref class))))
 516
 517 (export 'widget-get-style-properties)
 518
 519 (defun widget-style-property-info (type property-name)
 520   (let ((class (g-type-class-ref type)))
 521     (unwind-protect
 522          (let ((g-param-spec (gtk-widget-class-find-style-property class property-name)))
 523            (parse-g-param-spec g-param-spec))
 524       (g-type-class-unref class))))
 525
 526 (export 'widget-style-property-info)
 527
 528 (defun widget-style-property-type (widget property-name)
 529   (let ((property-info (widget-style-property-info (g-type-from-object widget) property-name)))
 530     (g-class-property-definition-type property-info)))
 531
 532 (defun widget-style-property-value (widget property-name &optional property-type)
 533   (unless property-type (setf property-type (widget-style-property-type widget property-name)))
 534   (setf property-type (gtype property-type))
 535   (with-foreign-object (gvalue 'g-value)
 536     (g-value-zero gvalue)
 537     (g-value-init gvalue property-type)
 538     (prog1 (gtk-widget-style-get-property widget property-name gvalue)
 539       (g-value-unset gvalue))))
 540
 541 (export 'widget-style-property-value)
 542
 543 (defcfun (widget-child-focus "gtk_widget_child_focus") :boolean
 544   (widget g-object)
 545   (direction direction-type))
 546
 547 (export 'widget-child-focus)
 548
 549 (defcfun (widget-child-notify "gtk_widget_child_notify") :void
 550   (widget (g-object widget))
 551   (property-name :string))
 552
 553 (export 'widget-child-notify)
 554
 555 (defcfun (widget-freeze-child-notify "gtk_widget_freeze_child_notify") :void
 556   (widget g-object))
 557
 558 (export 'widget-freeze-child-notify)
 559
 560 (defcfun (widget-settings "gtk_widget_get_settings") g-object
 561   (widget g-object))
 562
 563 (export 'widget-settings)
 564
 565 (defcfun (widget-clipboard "gtk_widget_get_clipboard") (g-object clipboard)
 566   (widget (g-object widget))
 567   (selection gdk-atom-as-string))
 568
 569 (export 'widget-clipboard)
 570
 571 (defcfun (widget-display "gtk_widget_get_display") g-object
 572   (widget g-object))
 573
 574 (export 'widget-display)
 575
 576 (defcfun (widget-root-window "gtk_widget_get_root_window") g-object
 577   (widget g-object))
 578
 579 (export 'widget-root-window)
 580
 581 (defcfun (widget-screen "gtk_widget_get_screen") g-object
 582   (widget g-object))
 583
 584 (export 'widget-screen)
 585
 586 (defcfun (widget-has-screen "gtk_widget_has_screen") :boolean
 587   (widget g-object))
 588
 589 (export 'widget-has-screen)
 590
 591 (defcfun (widget-thaw-child-notify "gtk_widget_thaw_child_notify") :void
 592   (widget g-object))
 593
 594 (export 'widget-thaw-child-notify)
 595
 596 (defcfun (widget-mnemonic-labels "gtk_widget_list_mnemonic_labels") (glist (g-object widget) :free-from-foreign t)
 597   (widget (g-object widget)))
 598
 599 (export 'widget-mnemonic-labels)
 600
 601 (defcfun (widget-add-mnemonic-label "gtk_widget_add_mnemonic_label") :void
 602   (widget g-object)
 603   (label g-object))
 604
 605 (export 'widget-add-mnemonic-label)
 606
 607 (defcfun (widget-remove-mnemonic-label "gtk_widget_remove_mnemonic_label") :void
 608   (widget g-object)
 609   (label g-object))
 610
 611 (export 'widget-remove-mnemonic-label)
 612
 613 (defcfun (widget-action "gtk_widget_get_action") g-object
 614   (widget g-object))
 615
 616 (export 'widget-action)
 617
 618 (defcfun (widget-composited-p "gtk_widget_is_composited") :boolean
 619   (widget g-object))
 620
 621 (export 'widget-composited-p)
 622
 623 (defcfun (widget-error-bell "gtk_widget_error_bell") :void
 624   (widget g-object))
 625
 626 (export 'widget-error-bell)
 627
 628 (defcfun (widget-trigger-tooltip-query "gtk_tooltip_trigger_tooltip_query") :void
 629   (widget g-object))
 630
 631 (export 'widget-trigger-tooltip-query)
 632
 633 (defcfun gtk-widget-get-snapshot g-object
 634   (widget g-object)
 635   (clip-rectangle (g-boxed-foreign rectangle)))
 636
 637 (defun widget-snapshot (widget &optional clip-rectangle)
 638   (gtk-widget-get-snapshot widget clip-rectangle))
 639
 640 (export 'widget-snapshot)