mdw@git.distorted.org.uk Git - clg/blob - gtk/gtk.lisp

   1 ;; Common Lisp bindings for GTK+ v2.0
   2 ;; Copyright (C) 1999-2001 Espen S. Johnsen <esj@stud.cs.uit.no>
   3 ;;
   4 ;; This library is free software; you can redistribute it and/or
   5 ;; modify it under the terms of the GNU Lesser General Public
   6 ;; License as published by the Free Software Foundation; either
   7 ;; version 2 of the License, or (at your option) any later version.
   8 ;;
   9 ;; This library is distributed in the hope that it will be useful,
  10 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12 ;; Lesser General Public License for more details.
  13 ;;
  14 ;; You should have received a copy of the GNU Lesser General Public
  15 ;; License along with this library; if not, write to the Free Software
  16 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  17
  18 ;; $Id: gtk.lisp,v 1.35 2005-02-22 23:07:35 espen Exp $
  19
  20
  21 (in-package "GTK")
  22
  23 ;;; Gtk version
  24
  25 (defbinding check-version () (copy-of string)
  26   (required-major unsigned-int)
  27   (required-minor unsigned-int)
  28   (required-micro unsigned-int))
  29
  30 (defbinding query-version () nil
  31   (major unsigned-int :out)
  32   (minor unsigned-int :out)
  33   (micro unsigned-int :out))
  34
  35 (defun gtk-version ()
  36   (multiple-value-bind (major minor micro)
  37       (query-version)
  38     (if (zerop micro)
  39         (format nil "Gtk+ v~A.~A" major minor)
  40       (format nil "Gtk+ v~A.~A.~A" major minor micro))))
  41
  42 (defbinding get-default-language () (copy-of pango:language))
  43
  44
  45 ;;;; Initalization
  46
  47 (defbinding (gtk-init "gtk_parse_args") () nil
  48   "Initializes the library without opening the display."
  49   (nil null)
  50   (nil null))
  51
  52 (defun clg-init (&optional display)
  53   "Initializes the system and starts the event handling"
  54   (unless (gdk:display-get-default)
  55     (gdk:gdk-init)
  56     (gtk-init)
  57     (prog1
  58         (gdk:display-open display)
  59       (add-fd-handler (gdk:display-connection-number) :input #'main-iterate-all)
  60       (setq *periodic-polling-function* #'main-iterate-all)
  61       (setq *max-event-to-sec* 0)
  62       (setq *max-event-to-usec* 1000))))
  63
  64
  65 ;;; About dialog
  66
  67 #+gtk2.6
  68 (progn
  69   (def-callback-marshal %about-dialog-activate-link-func
  70     (nil (dialog about-dialog) (link (copy-of string))))
  71
  72   (defbinding about-dialog-set-email-hook (function) nil
  73     ((callback %about-dialog-activate-link-func) pointer)
  74     ((register-callback-function function) unsigned-int)
  75     ((callback user-data-destroy-func) pointer))
  76
  77   (defbinding about-dialog-set-url-hook (function) nil
  78     ((callback %about-dialog-activate-link-func) pointer)
  79     ((register-callback-function function) unsigned-int)
  80     ((callback user-data-destroy-func) pointer)))
  81
  82
  83 ;;; Acccel group
  84
  85 (defbinding %accel-group-connect () nil
  86   (accel-group accel-group)
  87   (key unsigned-int)
  88   (modifiers gdk:modifier-type)
  89   (flags accel-flags)
  90   (gclosure gclosure))
  91
  92 (defun accel-group-connect (group accelerator function &optional flags)
  93   (multiple-value-bind (key modifiers) (accelerator-parse accelerator)
  94     (let ((gclosure (make-callback-closure function)))
  95       (%accel-group-connect group key modifiers flags gclosure)
  96       gclosure)))
  97
  98 (defbinding accel-group-connect-by-path (group path function) nil
  99   (group accel-group)
 100   (path string)
 101   ((make-callback-closure function) gclosure :return))
 102
 103 (defbinding %accel-group-disconnect (group gclosure) boolean
 104   (group accel-group)
 105   (gclosure gclosure))
 106
 107 (defbinding %accel-group-disconnect-key () boolean
 108   (group accel-group)
 109   (key unsigned-int)
 110   (modifiers gdk:modifier-type))
 111
 112 (defun accel-group-disconnect (group accelerator)
 113   (etypecase accelerator
 114     (gclosure (%accel-group-disconnect group accelerator))
 115     (string
 116      (multiple-value-bind (key modifiers) (accelerator-parse accelerator)
 117        (%accel-group-disconnect-key group key modifiers)))))
 118
 119 (defbinding accel-group-lock () nil
 120   (accel-group accel-group))
 121
 122 (defbinding accel-group-unlock () nil
 123   (accel-group accel-group))
 124
 125 (defbinding %accel-groups-activate () boolean
 126   (object gobject)
 127   (key unsigned-int)
 128   (modifiers gdk:modifier-type))
 129
 130 (defun accel-groups-activate (object accelerator)
 131   (multiple-value-bind (key modifiers) (accelerator-parse accelerator)
 132     (%accel-groups-activate object key modifiers)))
 133
 134 (defbinding accel-groups-from-object () (gslist accel-groups)
 135   (object gobject))
 136
 137 (defbinding accelerator-valid-p (key &optional modifiers) boolean
 138   (key unsigned-int)
 139   (modifiers gdk:modifier-type))
 140
 141 (defbinding %accelerator-parse () nil
 142   (accelerator string)
 143   (key unsigned-int :out)
 144   (modifiers gdk:modifier-type :out))
 145
 146 (defun accelerator-parse (accelerator)
 147   (multiple-value-bind (key modifiers) (%accelerator-parse accelerator)
 148     (if (zerop key)
 149         (error "Invalid accelerator: ~A" accelerator)
 150       (values key modifiers))))
 151
 152 (defbinding accelerator-name () string
 153   (key unsigned-int)
 154   (modifiers gdk:modifier-type))
 155
 156 #+gtk2.6
 157 (defbinding accelerator-get-label () string
 158   (key unsigned-int)
 159   (modifiers gdk:modifier-type))
 160
 161 (defbinding %accelerator-set-default-mod-mask () nil
 162   (default-modifiers gdk:modifier-type))
 163
 164 (defun (setf accelerator-default-modifier-mask) (default-modifiers)
 165   (%accelerator-set-default-mod-mask default-modifiers))
 166
 167 (defbinding (accelerator-default-modifier-mask "gtk_accelerator_get_default_mod_mask") () gdk:modifier-type)
 168
 169
 170 ;;; Acccel label
 171
 172 (defbinding accel-label-refetch () boolean
 173   (accel-label accel-label))
 174
 175
 176
 177 ;;; Accel map
 178
 179 (defbinding %accel-map-add-entry () nil
 180   (path string)
 181   (key unsigned-int)
 182   (modifiers gdk:modifier-type))
 183
 184 (defun accel-map-add-entry (path accelerator)
 185   (multiple-value-bind (key modifiers) (accelerator-parse accelerator)
 186     (%accel-map-add-entry path key modifiers)))
 187
 188 (defbinding accel-map-lookup-entry () boolean
 189   (path string)
 190   (key pointer)) ;accel-key))
 191
 192 (defbinding %accel-map-change-entry () boolean
 193   (path string)
 194   (key unsigned-int)
 195   (modifiers gdk:modifier-type)
 196   (replace boolean))
 197
 198 (defun accel-map-change-entry (path accelerator &optional replace)
 199   (multiple-value-bind (key modifiers) (accelerator-parse accelerator)
 200     (%accel-map-change-entry path key modifiers replace)))
 201
 202 (defbinding accel-map-load () nil
 203   (filename pathname))
 204
 205 (defbinding accel-map-save () nil
 206   (filename pathname))
 207
 208 (defbinding accel-map-get () accel-map)
 209
 210 (defbinding accel-map-lock-path () nil
 211   (path string))
 212
 213 (defbinding accel-map-unlock-path () nil
 214   (path string))
 215
 216
 217
 218 ;;; Accessible
 219
 220 (defbinding accessible-connect-widget-destroyed () nil
 221   (accessible accessible))
 222
 223
 224 ;;; Adjustment
 225
 226 (defmethod initialize-instance ((adjustment adjustment) &key value)
 227   (prog1
 228       (call-next-method)
 229     ;; we need to make sure that the value is set last, otherwise it
 230     ;; may be outside current limits and ignored
 231     (when value
 232       (setf (slot-value adjustment 'value) value))))
 233
 234
 235 (defbinding adjustment-changed () nil
 236   (adjustment adjustment))
 237
 238 (defbinding adjustment-value-changed () nil
 239   (adjustment adjustment))
 240
 241 (defbinding adjustment-clamp-page () nil
 242   (adjustment adjustment)
 243   (lower single-float)
 244   (upper single-float))
 245
 246
 247 ;;; Alignment
 248
 249 (defbinding alignment-set () nil
 250   (alognment alignment)
 251   (x-align single-float)
 252   (y-align single-float)
 253   (x-scale single-float)
 254   (y-scale single-float))
 255
 256 (defbinding alignment-get-padding () nil
 257   (alognment alignment)
 258   (top unsigned-int :out)
 259   (bottom unsigned-int :out)
 260   (left unsigned-int :out)
 261   (right unsigned-int :out))
 262
 263 (defbinding alignment-set-padding () nil
 264   (alognment alignment)
 265   (top unsigned-int)
 266   (bottom unsigned-int)
 267   (left unsigned-int)
 268   (right unsigned-int))
 269
 270
 271 ;;; Aspect frame
 272
 273
 274 ;;; Bin
 275
 276 (defun (setf bin-child) (child bin)
 277   (when-bind (current-child (bin-child bin))
 278     (container-remove bin current-child))
 279   (container-add bin child)
 280   child)
 281
 282 (defmethod compute-signal-function ((bin bin) signal function object)
 283   (declare (ignore signal))
 284   (if (eq object :child)
 285       #'(lambda (&rest args)
 286           (apply function (bin-child bin) (rest args)))
 287     (call-next-method)))
 288
 289
 290 ;;; Box
 291
 292 (defbinding box-pack-start () nil
 293   (box box)
 294   (child widget)
 295   (expand boolean)
 296   (fill boolean)
 297   (padding unsigned-int))
 298
 299 (defbinding box-pack-end () nil
 300   (box box)
 301   (child widget)
 302   (expand boolean)
 303   (fill boolean)
 304   (padding unsigned-int))
 305
 306 (defun box-pack (box child &key end (expand t) (fill t) (padding 0))
 307   (if end
 308       (box-pack-end box child expand fill padding)
 309     (box-pack-start box child expand fill padding)))
 310
 311 (defbinding box-reorder-child () nil
 312   (box box)
 313   (child widget)
 314   (position int))
 315
 316 (defbinding box-query-child-packing () nil
 317   (box box)
 318   (child widget)
 319   (expand boolean :out)
 320   (fill boolean :out)
 321   (padding unsigned-int :out)
 322   (pack-type pack-type :out))
 323
 324 (defbinding box-set-child-packing () nil
 325   (box box)
 326   (child widget)
 327   (expand boolean)
 328   (fill boolean)
 329   (padding unsigned-int)
 330   (pack-type pack-type))
 331
 332
 333
 334 ;;; Button
 335
 336 (defmethod initialize-instance ((button button) &rest initargs &key stock)
 337   (if stock
 338       (apply #'call-next-method button :label stock :use-stock t initargs)
 339     (call-next-method)))
 340
 341
 342 (defbinding button-pressed () nil
 343   (button button))
 344
 345 (defbinding button-released () nil
 346   (button button))
 347
 348 (defbinding button-clicked () nil
 349   (button button))
 350
 351 (defbinding button-enter () nil
 352   (button button))
 353
 354 (defbinding button-leave () nil
 355   (button button))
 356
 357
 358
 359 ;;; Calendar
 360
 361 (defbinding calendar-select-month () int
 362   (calendar calendar)
 363   (month unsigned-int)
 364   (year unsigned-int))
 365
 366 (defbinding calendar-select-day () nil
 367   (calendar calendar)
 368   (day unsigned-int))
 369
 370 (defbinding calendar-mark-day () int
 371   (calendar calendar)
 372   (day unsigned-int))
 373
 374 (defbinding calendar-unmark-day () int
 375   (calendar calendar)
 376   (day unsigned-int))
 377
 378 (defbinding calendar-clear-marks () nil
 379   (calendar calendar))
 380
 381 (defbinding calendar-get-date () nil
 382   (calendar calendar)
 383   (year unsigned-int :out)
 384   (month unsigned-int :out)
 385   (day unsigned-int :out))
 386
 387 (defbinding calendar-freeze () nil
 388   (calendar calendar))
 389
 390 (defbinding calendar-thaw () nil
 391   (calendar calendar))
 392
 393
 394 ;;; Check menu item
 395
 396 (defbinding check-menu-item-toggled () nil
 397   (check-menu-item check-menu-item))
 398
 399
 400 ;;; Color selection
 401
 402 (defbinding (color-selection-is-adjusting-p
 403              "gtk_color_selection_is_adjusting") () boolean
 404   (colorsel color-selection))
 405
 406
 407
 408 ;;; Color selection dialog -- no functions
 409
 410
 411
 412 ;;;; Combo Box
 413
 414 (defmethod initialize-instance ((combo-box combo-box) &rest initargs
 415                                 &key model content active)
 416   (remf initargs :active)
 417   (if model
 418       (apply #'call-next-method combo-box initargs)
 419     (progn
 420       (apply #'call-next-method combo-box
 421        :model (make-instance 'list-store :column-types '(string))
 422        initargs)
 423       (unless (typep combo-box 'combo-box-entry)
 424         (let ((cell (make-instance 'cell-renderer-text)))
 425           (cell-layout-pack combo-box cell :expand t)
 426           (cell-layout-add-attribute combo-box cell :text 0)))))
 427   (when content
 428     (mapc #'(lambda (text)
 429               (combo-box-append-text combo-box text))
 430           content))
 431   (when active
 432     (setf (combo-box-active combo-box) active)))
 433
 434
 435 ;; (defmethod shared-initialize :after ((combo-box combo-box) names &key active)
 436 ;;   (when active
 437 ;;     (signal-emit combo-box 'changed)))
 438
 439 (defbinding combo-box-append-text () nil
 440   (combo-box combo-box)
 441   (text string))
 442
 443 (defbinding combo-box-insert-text () nil
 444   (combo-box combo-box)
 445   (position int)
 446   (text string))
 447
 448 (defbinding combo-box-prepend-text () nil
 449   (combo-box combo-box)
 450   (text string))
 451
 452 #+gtk2.6
 453 (defbinding combo-box-get-active-text () string
 454   (combo-box combo-box))
 455
 456 (defbinding combo-box-popup () nil
 457   (combo-box combo-box))
 458
 459 (defbinding combo-box-popdown () nil
 460   (combo-box combo-box))
 461
 462
 463
 464 ;;;; Combo Box Entry
 465
 466 (defmethod initialize-instance ((combo-box-entry combo-box-entry) &key model)
 467   (call-next-method)
 468   (unless model
 469     (setf (combo-box-entry-text-column combo-box-entry) 0)))
 470
 471
 472 ;;;; Dialog
 473
 474 (defmethod shared-initialize ((dialog dialog) names &rest initargs
 475                               &key button buttons)
 476   (declare (ignore button buttons))
 477   (prog1
 478       (call-next-method)
 479     (initial-apply-add dialog #'dialog-add-button initargs :button :buttons)))
 480
 481
 482 (defun dialog-response-id (dialog response &optional create-p error-p)
 483   "Returns a numeric response id"
 484   (if (typep response 'response-type)
 485       (response-type-to-int response)
 486     (let ((responses (object-data dialog 'responses)))
 487       (cond
 488        ((and responses (position response responses :test #'equal)))
 489        (create-p
 490        (cond
 491          (responses
 492           (vector-push-extend response responses)
 493           (1- (length responses)))
 494          (t
 495           (setf
 496            (object-data dialog 'responses)
 497            (make-array 1 :adjustable t :fill-pointer t
 498                        :initial-element response))
 499           0)))
 500       (error-p
 501        (error "Invalid response: ~A" response))))))
 502
 503 (defun dialog-find-response (dialog id)
 504   "Finds a symbolic response given a numeric id"
 505   (if (< id 0)
 506       (int-to-response-type id)
 507     (aref (object-data dialog 'responses) id)))
 508
 509
 510 (defmethod compute-signal-id ((dialog dialog) signal)
 511   (if (dialog-response-id dialog signal)
 512       (ensure-signal-id 'response dialog)
 513     (call-next-method)))
 514
 515 (defmethod compute-signal-function ((dialog dialog) signal function object)
 516   (declare (ignore function object))
 517   (let ((callback (call-next-method))
 518         (id (dialog-response-id dialog signal)))
 519     (if id
 520         #'(lambda (dialog response)
 521             (when (= response id)
 522               (funcall callback dialog)))
 523       callback)))
 524
 525 (defbinding dialog-run () nil
 526   (dialog dialog))
 527
 528 (defbinding dialog-response (dialog response) nil
 529   (dialog dialog)
 530   ((dialog-response-id dialog response nil t) int))
 531
 532
 533 (defbinding %dialog-add-button () button
 534   (dialog dialog)
 535   (text string)
 536   (response-id int))
 537
 538 (defun dialog-add-button (dialog label &optional (response label)
 539                           &key default object after)
 540   "Adds a button to the dialog."
 541   (let* ((signal (if (functionp response)
 542                      label
 543                    response))
 544          (id (dialog-response-id dialog signal t))
 545          (button (%dialog-add-button dialog label id)))
 546     (when (functionp response)
 547        (signal-connect dialog signal response :object object :after after))
 548     (when default
 549       (%dialog-set-default-response dialog id))
 550     button))
 551
 552
 553 (defbinding %dialog-add-action-widget () nil
 554   (dialog dialog)
 555   (action-widget widget)
 556   (response-id int))
 557
 558 (defun dialog-add-action-widget (dialog widget &optional (response widget)
 559                                  &key default object after)
 560   (let* ((signal (if (functionp response)
 561                      widget
 562                    response))
 563          (id (dialog-response-id dialog signal t)))
 564     (unless (widget-hidden-p widget)
 565       (widget-show widget))
 566     (%dialog-add-action-widget dialog widget id)
 567     (when (functionp response)
 568        (signal-connect dialog signal response :object object :after after))
 569     (when default
 570       (%dialog-set-default-response dialog id))
 571     widget))
 572
 573
 574 (defbinding %dialog-set-default-response () nil
 575   (dialog dialog)
 576   (response-id int))
 577
 578 (defun dialog-set-default-response (dialog response)
 579   (%dialog-set-default-response
 580    dialog (dialog-response-id dialog response nil t)))
 581
 582 (defbinding dialog-set-response-sensitive (dialog response sensitive) nil
 583   (dialog dialog)
 584   ((dialog-response-id dialog response nil t) int)
 585   (sensitive boolean))
 586
 587 #+gtk2.6
 588 (defbinding alternative-dialog-button-order-p (&optional screen) boolean
 589   (screen (or null gdk:screen)))
 590
 591 #+gtk2.6
 592 (defbinding (dialog-set-alternative-button-order
 593              "gtk_dialog_set_alternative_button_order_from_array")
 594     (dialog new-order)
 595   (dialog dialog)
 596   ((length new-order) int)
 597   ((map 'vector #'(lambda (response)
 598                     (dialog-response-id dialog response nil t))
 599         new-order) (vector int)))
 600
 601
 602 (defmethod container-add ((dialog dialog) (child widget) &rest args)
 603   (apply #'container-add (dialog-vbox dialog) child args))
 604
 605
 606 (defmethod container-remove ((dialog dialog) (child widget))
 607   (container-remove (dialog-vbox dialog) child))
 608
 609 (defmethod container-children ((dialog dialog))
 610   (container-children (dialog-vbox dialog)))
 611
 612 (defmethod (setf container-children) (children (dialog dialog))
 613   (setf (container-children (dialog-vbox dialog)) children))
 614
 615
 616 ;;; Entry
 617
 618 (defbinding entry-get-layout-offsets () nil
 619   (entry entry)
 620   (x int :out)
 621   (y int :out))
 622
 623 (defbinding entry-layout-index-to-text-index () int
 624   (entry entry)
 625   (layout-index int))
 626
 627 (defbinding entry-text-index-to-layout-index () int
 628   (entry entry)
 629   (text-index int))
 630
 631
 632 ;;; Entry Completion
 633
 634 (def-callback-marshal %entry-completion-match-func
 635     (boolean entry-completion string (copy-of tree-iter)))
 636
 637 (defbinding entry-completion-set-match-func (completion function) nil
 638   (completion entry-completion)
 639   ((callback %entry-completion-match-func) pointer)
 640   ((register-callback-function function) unsigned-int)
 641   ((callback user-data-destroy-func) pointer))
 642
 643 (defbinding entry-completion-complete () nil
 644   (completion entry-completion))
 645
 646 #+gtk2.6
 647 (defbinding entry-completion-insert-prefix () nil
 648   (completion entry-completion))
 649
 650 (defbinding entry-completion-insert-action-text () nil
 651   (completion entry-completion)
 652   (index int)
 653   (text string))
 654
 655 (defbinding entry-completion-insert-action-markup () nil
 656   (completion entry-completion)
 657   (index int)
 658   (markup string))
 659
 660 (defbinding entry-completion-delete-action () nil
 661   (completion entry-completion)
 662   (index int))
 663
 664
 665 ;;; File Chooser
 666
 667 (defmethod initialize-instance ((file-chooser file-chooser) &rest initargs
 668                                 &key filter filters shortcut-folder
 669                                 shortcut-folders shortcut-folder-uti
 670                                 shortcut-folder-uris)
 671   (declare (ignore filter filters shortcut-folder shortcut-folders
 672                    shortcut-folder-uti shortcut-folder-uris))
 673   (prog1
 674       (call-next-method)
 675     (initial-add file-chooser #'file-chooser-add-filter
 676      initargs :filer :filters)
 677     (initial-add file-chooser #'file-chooser-add-shortcut-folder
 678      initargs :shortcut-folder :shortcut-folders)
 679     (initial-add file-chooser #'file-chooser-add-shortcut-folder-uri
 680      initargs :shortcut-folder-uri :shortcut-folders-uris)))
 681
 682
 683 (defbinding file-chooser-select-filename () boolean
 684   (file-chooser file-chooser)
 685   (filename string))
 686
 687 (defbinding file-chooser-unselect-filename () nil
 688   (file-chooser file-chooser)
 689   (filename string))
 690
 691 (defbinding file-chooser-select-all () boolean
 692   (file-chooser file-chooser))
 693
 694 (defbinding file-chooser-unselect-all () boolean
 695   (file-chooser file-chooser))
 696
 697 (defbinding file-chooser-get-filenames () (gslist string)
 698   (file-chooser file-chooser))
 699
 700 (defbinding file-chooser-select-uri () boolean
 701   (file-chooser file-chooser)
 702   (uri string))
 703
 704 (defbinding file-chooser-unselect-uri () nil
 705   (file-chooser file-chooser)
 706   (uri string))
 707
 708 (defbinding file-chooser-get-uris () (gslist string)
 709   (file-chooser file-chooser))
 710
 711 (defbinding file-chooser-add-filter () nil
 712   (file-chooser file-chooser)
 713   (filter file-filter))
 714
 715 (defbinding file-chooser-remove-filter () nil
 716   (file-chooser file-chooser)
 717   (filter file-filter))
 718
 719 (defbinding file-chooser-list-filters () (gslist file-filter)
 720   (file-chooser file-chooser))
 721
 722 (defbinding file-chooser-add-shortcut-folder () boolean
 723   (file-chooser file-chooser)
 724   (folder string)
 725   (nil null))
 726
 727 (defbinding file-chooser-remove-shortcut-folder () nil
 728   (file-chooser file-chooser)
 729   (folder string)
 730   (nil null))
 731
 732 (defbinding file-chooser-list-shortcut-folders () (gslist string)
 733   (file-chooser file-chooser))
 734
 735 (defbinding file-chooser-add-shortcut-folder-uri () boolean
 736   (file-chooser file-chooser)
 737   (uri string)
 738   (nil null))
 739
 740 (defbinding file-chooser-remove-shortcut-folder-uri () nil
 741   (file-chooser file-chooser)
 742   (uri string)
 743   (nil null))
 744
 745 (defbinding file-chooser-list-shortcut-folder-uris () (gslist string)
 746   (file-chooser file-chooser))
 747
 748
 749 ;;; File Filter
 750
 751 (defmethod initialize-instance ((file-filter file-filter) &rest initargs
 752                                 &key mime-type mime-types pattern patterns
 753                                 pixbuf-formats)
 754   (declare (ignore mime-type mime-types pattern patterns))
 755   (prog1
 756       (call-next-method)
 757     (when pixbuf-formats
 758       #-gtk2.6(warn "Initarg :PIXBUF-FORMATS not supportet in this version of Gtk")
 759       #+gtk2.6(file-filter-add-pixbuf-formats file-filter))
 760     (initial-add file-filter #'file-filter-add-mime-type
 761      initargs :mime-type :mime-types)
 762     (initial-add file-filter #'file-filter-add-pattern
 763      initargs :pattern :patterns)))
 764
 765
 766 (defbinding file-filter-add-mime-type () nil
 767   (filter file-filter)
 768   (mime-type string))
 769
 770 (defbinding file-filter-add-pattern () nil
 771   (filter file-filter)
 772   (pattern string))
 773
 774 #+gtk2.6
 775 (defbinding file-filter-add-pixbuf-formats () nil
 776   (filter file-filter))
 777
 778 (def-callback-marshal %file-filter-func (boolean file-filter-info))
 779
 780 (defbinding file-filter-add-custom (filter needed function) nil
 781   (filter file-filter)
 782   (needed file-filter-flags)
 783   ((callback %file-filter-func) pointer)
 784   ((register-callback-function function) unsigned-int)
 785   ((callback user-data-destroy-func) pointer))
 786
 787 (defbinding file-filter-get-needed () file-filter-flags
 788   (filter file-filter))
 789
 790 (defbinding file-filter-filter () boolean
 791   (filter file-filter)
 792   (filter-info file-filter-info))
 793
 794
 795
 796 ;;; Image
 797
 798 (defbinding image-set-from-file () nil
 799   (image image)
 800   (filename pathname))
 801
 802 (defmethod (setf image-pixmap) ((data vector) (image image))
 803   (multiple-value-bind (pixmap mask) (gdk:pixmap-create data)
 804     (setf (image-pixmap image) pixmap)
 805     (setf (image-mask image) mask)))
 806
 807 (defmethod initialize-instance ((image image) &rest initargs &key pixmap file)
 808   (cond
 809    ((typep pixmap 'vector)
 810     (multiple-value-bind (pixmap mask) (gdk:pixmap-create pixmap)
 811       (apply #'call-next-method image :pixmap pixmap :mask mask initargs)))
 812    (file
 813     (prog1
 814         (call-next-method)
 815       (image-set-from-file image file)))
 816    ((call-next-method))))
 817
 818 (defun create-image-widget (source &optional mask)
 819   (etypecase source
 820     (gdk:pixbuf (make-instance 'image :pixbuf source))
 821     (string (make-instance 'image :stock source))
 822     (pathname (make-instance 'image :file source))
 823     ((or list vector) (make-instance 'image :pixmap source))
 824     (gdk:pixmap (make-instance 'image :pixmap source :mask mask))))
 825
 826
 827 ;;; Image menu item
 828
 829 (defmethod initialize-instance ((item image-menu-item) &rest initargs &key image)
 830   (if (and image (not (typep image 'widget)))
 831       (apply #'call-next-method item :image (create-image-widget image) initargs)
 832     (call-next-method)))
 833
 834
 835 (defmethod (setf image-menu-item-image) ((widget widget) (item image-menu-item))
 836   (setf (slot-value item 'image) widget))
 837
 838 (defmethod (setf image-menu-item-image) (image (item image-menu-item))
 839   (setf (image-menu-item-image item) (create-image-widget image)))
 840
 841
 842 ;;; Label
 843
 844 (defbinding label-get-layout-offsets () nil
 845   (label label)
 846   (x int :out)
 847   (y int :out))
 848
 849 (defbinding label-select-region () nil
 850   (label label)
 851   (start int)
 852   (end int))
 853
 854 (defbinding label-get-selection-bounds () boolean
 855   (label label)
 856   (start int :out)
 857   (end int :out))
 858
 859
 860
 861 ;;; Radio button
 862
 863 (defbinding %radio-button-get-group () pointer
 864   (radio-button radio-button))
 865
 866 (defbinding %radio-button-set-group () nil
 867   (radio-button radio-button)
 868   (group pointer))
 869
 870 (defmethod add-to-radio-group ((button1 radio-button) (button2 radio-button))
 871   "Add BUTTON1 to the group which BUTTON2 belongs to."
 872   (%radio-button-set-group button1 (%radio-button-get-group button2)))
 873
 874 (defmethod initialize-instance ((button radio-button) &key group)
 875   (prog1
 876       (call-next-method)
 877     (when group
 878       (add-to-radio-group button group))))
 879
 880
 881 ;;; Item
 882
 883 (defbinding item-select () nil
 884   (item item))
 885
 886 (defbinding item-deselect () nil
 887   (item item))
 888
 889 (defbinding item-toggle () nil
 890   (item item))
 891
 892
 893
 894 ;;; Menu item
 895
 896 (defmethod initialize-instance ((item menu-item) &key label)
 897   (prog1
 898       (call-next-method)
 899     (when label
 900       (setf (menu-item-label item) label))))
 901
 902
 903 (defun (setf menu-item-label) (label menu-item)
 904   (make-instance 'accel-label
 905    :label label :xalign 0.0 :yalign 0.5 :accel-widget menu-item
 906    :use-underline (menu-item-use-underline-p menu-item)
 907    :visible t  :parent menu-item)
 908   label)
 909
 910 (defun menu-item-label (menu-item)
 911   (when (and (slot-boundp menu-item 'child)
 912              (typep (bin-child menu-item) 'label))
 913     (label-label (bin-child menu-item))))
 914
 915 (defbinding menu-item-remove-submenu () nil
 916   (menu-item menu-item))
 917
 918 (defbinding menu-item-set-accel-path () nil
 919   (menu-item menu-item)
 920   (accel-path string))
 921
 922 (defbinding menu-item-select () nil
 923   (menu-item menu-item))
 924
 925 (defbinding menu-item-deselect () nil
 926   (menu-item menu-item))
 927
 928 (defbinding menu-item-activate () nil
 929   (menu-item menu-item))
 930
 931 (defbinding menu-item-toggle-size-request () nil
 932   (menu-item menu-item)
 933   (requisition int :out))
 934
 935 (defbinding menu-item-toggle-size-allocate () nil
 936   (menu-item menu-item)
 937   (allocation int))
 938
 939
 940 ;;; Menu tool button
 941
 942 #+gtk2.6
 943 (defbinding menu-tool-button-set-arrow-tooltip () nil
 944   (menu-tool-button menu-tool-button)
 945   (tooltips tooltips)
 946   (tip-text string)
 947   (tip-private string))
 948
 949
 950 ;;; Message dialog
 951
 952 (defmethod initialize-instance ((dialog message-dialog) &rest initargs
 953                                 &key (type :info) (buttons :close) ; or :ok?
 954                                 flags message parent)
 955   (remf initargs :parent)
 956   (setf
 957    (slot-value dialog 'location)
 958    (%message-dialog-new parent flags type buttons nil))
 959   (message-dialog-set-markup dialog message)
 960   (apply #'call-next-method dialog initargs))
 961
 962
 963 (defbinding %message-dialog-new () pointer
 964   (parent (or null window))
 965   (flags dialog-flags)
 966   (type message-type)
 967   (buttons buttons-type)
 968   (message (or null string)))
 969
 970 (defbinding %message-dialog-new-with-markup () pointer
 971   (parent (or null window))
 972   (flags dialog-flags)
 973   (type message-type)
 974   (buttons buttons-type)
 975   (message string))
 976
 977 (defbinding message-dialog-set-markup () nil
 978   (message-dialog message-dialog)
 979   (markup string))
 980
 981 #+gtk2.6
 982 (defbinding message-dialog-format-secondary-text () nil
 983   (message-dialog message-dialog)
 984   (text string))
 985
 986 #+gtk2.6
 987 (defbinding message-dialog-format-secondary-markup () nil
 988   (message-dialog message-dialog)
 989   (markup string))
 990
 991
 992
 993 ;;; Radio menu item
 994
 995 (defbinding %radio-menu-item-get-group () pointer
 996   (radio-menu-item radio-menu-item))
 997
 998 (defbinding %radio-menu-item-set-group () nil
 999   (radio-menu-item radio-menu-item)
1000   (group pointer))
1001
1002 (defmethod add-to-radio-group ((item1 radio-menu-item) (item2 radio-menu-item))
1003   "Add ITEM1 to the group which ITEM2 belongs to."
1004   (%radio-menu-item-set-group item1 (%radio-menu-item-get-group item2)))
1005
1006 (defmethod initialize-instance ((item radio-menu-item) &key group)
1007   (prog1
1008       (call-next-method)
1009     (when group
1010       (add-to-radio-group item group))))
1011
1012
1013
1014 ;;; Radio tool button
1015
1016 (defbinding %radio-tool-button-get-group () pointer
1017   (radio-tool-button radio-tool-button))
1018
1019 (defbinding %radio-tool-button-set-group () nil
1020   (radio-tool-button radio-tool-button)
1021   (group pointer))
1022
1023 (defmethod add-to-radio-group ((button1 radio-tool-button) (button2 radio-tool-button))
1024   "Add BUTTON1 to the group which BUTTON2 belongs to."
1025   (%radio-tool-button-set-group button1 (%radio-tool-button-get-group button2)))
1026
1027 (defmethod add-activate-callback ((widget widget) function &key object after)
1028   (if object
1029       (signal-connect widget 'clicked
1030        #'(lambda (object)
1031            (when (slot-value widget 'active)
1032              (funcall function object (slot-value widget 'value))))
1033        :object object :after after)
1034     (signal-connect widget 'clicked
1035      #'(lambda ()
1036          (when (slot-value widget 'active)
1037            (funcall function (slot-value widget 'value))))
1038      :after after)))
1039
1040 (defmethod initialize-instance ((button radio-tool-button) &key group)
1041   (prog1
1042       (call-next-method)
1043     (when group
1044       (add-to-radio-group button group))))
1045
1046
1047
1048 ;;; Toggle button
1049
1050 (defbinding toggle-button-toggled () nil
1051   (toggle-button toggle-button))
1052
1053
1054 ;;; Window
1055
1056 (defmethod initialize-instance ((window window) &rest initargs
1057                                 &key accel-group accel-groups)
1058   (declare (ignore accel-group accel-groups))
1059   (prog1
1060       (call-next-method)
1061     (initial-add window #'window-add-accel-group
1062      initargs :accel-group :accel-groups)))
1063
1064
1065 (defbinding window-set-wmclass () nil
1066   (window window)
1067   (wmclass-name string)
1068   (wmclass-class string))
1069
1070 (defbinding window-add-accel-group () nil
1071   (window window)
1072   (accel-group accel-group))
1073
1074 (defbinding window-remove-accel-group () nil
1075   (window window)
1076   (accel-group accel-group))
1077
1078 (defbinding window-activate-focus () int
1079   (window window))
1080
1081 (defbinding window-activate-default () int
1082   (window window))
1083
1084 (defbinding window-set-default-size (window width height) int
1085   (window window)
1086   ((or width -1) int)
1087   ((or height -1) int))
1088
1089 (defbinding %window-set-geometry-hints () nil
1090   (window window)
1091   (geometry gdk:geometry)
1092   (geometry-mask gdk:window-hints))
1093
1094 (defun window-set-geometry-hints (window &key min-width min-height
1095                                   max-width max-height base-width base-height
1096                                   width-inc height-inc min-aspect max-aspect
1097                                   (gravity nil gravity-p) min-size max-size)
1098   (let ((geometry (make-instance 'gdk:geometry
1099                    :min-width (or min-width -1)
1100                    :min-height (or min-height -1)
1101                    :max-width (or max-width -1)
1102                    :max-height (or max-height -1)
1103                    :base-width (or base-width 0)
1104                    :base-height (or base-height 0)
1105                    :width-inc (or width-inc 0)
1106                    :height-inc (or height-inc 0)
1107                    :min-aspect (or min-aspect 0)
1108                    :max-aspect (or max-aspect 0)
1109                    :gravity gravity))
1110         (mask ()))
1111     (when (or min-size min-width min-height)
1112       (push :min-size mask))
1113     (when (or max-size max-width max-height)
1114       (push :max-size mask))
1115     (when (or base-width base-height)
1116       (push :base-size mask))
1117     (when (or width-inc height-inc)
1118       (push :resize-inc mask))
1119     (when (or min-aspect max-aspect)
1120       (push :aspect mask))
1121     (when gravity-p
1122       (push :win-gravity mask))
1123     (%window-set-geometry-hints window geometry mask)))
1124
1125 (defbinding window-list-toplevels () (glist (copy-of window))
1126   "Returns a list of all existing toplevel windows.")
1127
1128 (defbinding window-add-mnemonic (window key target) nil
1129   (window window)
1130   ((gdk:keyval-from-name key) unsigned-int)
1131   (target widget))
1132
1133 (defbinding window-remove-mnemonic (window key target) nil
1134   (window window)
1135   ((gdk:keyval-from-name key) unsigned-int)
1136   (target widget))
1137
1138 (defbinding window-mnemonic-activate (window key modifier) nil
1139   (window window)
1140   ((gdk:keyval-from-name key) unsigned-int)
1141   (modifier gdk:modifier-type))
1142
1143 (defbinding window-activate-key () boolean
1144   (window window)
1145   (event gdk:key-event))
1146
1147 (defbinding window-propagate-key-event () boolean
1148   (window window)
1149   (event gdk:key-event))
1150
1151 (defbinding window-present () nil
1152   (window window))
1153
1154 (defbinding window-iconify () nil
1155   (window window))
1156
1157 (defbinding window-deiconify () nil
1158   (window window))
1159
1160 (defbinding window-stick () nil
1161   (window window))
1162
1163 (defbinding window-unstick () nil
1164   (window window))
1165
1166 (defbinding window-maximize () nil
1167   (window window))
1168
1169 (defbinding window-unmaximize () nil
1170   (window window))
1171
1172 (defbinding window-fullscreen () nil
1173   (window window))
1174
1175 (defbinding window-unfullscreen () nil
1176   (window window))
1177
1178 (defbinding window-set-keep-above () nil
1179   (window window)
1180   (setting boolean))
1181
1182 (defbinding window-set-keep-below () nil
1183   (window window)
1184   (setting boolean))
1185
1186 (defbinding window-begin-resize-drag () nil
1187   (window window)
1188   (edge gdk:window-edge)
1189   (button int)
1190   (root-x int) (root-y int)
1191   (timestamp unsigned-int))
1192
1193 (defbinding window-begin-move-drag () nil
1194   (window window)
1195   (edge gdk:window-edge)
1196   (button int)
1197   (root-x int) (root-y int)
1198   (timestamp unsigned-int))
1199
1200 (defbinding window-set-frame-dimensions () nil
1201   (window window)
1202   (left int) (top int) (rigth int) (bottom int))
1203
1204 (defbinding %window-get-default-size () nil
1205   (window window)
1206   (width int :out)
1207   (height int :out))
1208
1209 (defun window-get-default-size (window)
1210   (multiple-value-bind (width height) (%window-get-default-size window)
1211     (values (unless (= width -1) width) (unless (= height -1) height))))
1212
1213 (defbinding window-get-frame-dimensions () nil
1214   (window window)
1215   (left int :out) (top int :out) (rigth int :out) (bottom int :out))
1216
1217 (defbinding %window-get-icon-list () (glist gdk:pixbuf)
1218   (window window))
1219
1220 (defbinding window-get-position () nil
1221   (window window)
1222   (root-x int :out)
1223   (root-y int :out))
1224
1225 (defbinding window-get-size () nil
1226   (window window)
1227   (width int :out)
1228   (height int :out))
1229
1230 (defbinding window-move () nil
1231   (window window)
1232   (x int)
1233   (y int))
1234
1235 (defbinding window-parse-geometry () boolean
1236   (window window)
1237   (geometry string))
1238
1239 (defbinding window-reshow-with-initial-size () nil
1240   (window window))
1241
1242 (defbinding window-resize () nil
1243   (window window)
1244   (width int)
1245   (heigth int))
1246
1247 (defbinding (window-default-icon-list "gtk_window_get_default_icon_list")
1248     () (glist gdk:pixbuf))
1249
1250 (defun window-default-icon ()
1251   (first (window-default-icon-list)))
1252
1253 (defbinding %window-set-default-icon-list () nil
1254   (icons (glist gdk:pixbuf)))
1255
1256 (defun (setf window-default-icon-list) (icons)
1257   (%window-set-default-icon-list icons)
1258   icons)
1259
1260 (defbinding %window-set-default-icon () nil
1261   (icons (glist gdk:pixbuf)))
1262
1263 (defmethod (setf window-default-icon) ((icon gdk:pixbuf))
1264   (%window-set-default-icon icon)
1265   icon)
1266
1267 (defmethod (setf window-group) ((group window-group) (window window))
1268   (window-group-add-window group window)
1269   group)
1270
1271 (defbinding %window-set-default-icon-from-file () boolean
1272   (filename pathname)
1273   (nil null))
1274
1275 (defmethod (setf window-default-icon) ((icon-file pathname))
1276   (%window-set-default-icon-from-file icon-file)
1277   icon-file)
1278
1279 (defbinding %window-set-icon-from-file () boolean
1280   (window window)
1281   (filename pathname)
1282   (nil null))
1283
1284 (defmethod (setf window-icon) ((icon-file pathname) (window window))
1285   (%window-set-icon-from-file window icon-file)
1286   icon-file)
1287
1288 (defbinding window-set-auto-startup-notification () nil
1289   (setting boolean))
1290
1291 (defbinding decorated-window-init () nil
1292   (window window))
1293
1294 (defbinding decorated-window-calculate-frame-size () nil
1295   (window window))
1296
1297 (defbinding decorated-window-set-title () nil
1298   (window window)
1299   (title string))
1300
1301 (defbinding decorated-window-move-resize-window () nil
1302   (window window)
1303   (x int)
1304   (y int)
1305   (width int)
1306   (heigth int))
1307
1308
1309 ;;; Window group
1310
1311 (defmethod initialize-instance ((window-group window-group) &rest initargs
1312                                 &key window windows)
1313   (declare (ignore window windows))
1314   (prog1
1315       (call-next-method)
1316     (initial-add window-group #'window-group-add-window
1317      initargs :window :windows)))
1318
1319
1320 (defbinding window-group-add-window () nil
1321   (window-group window-group)
1322   (window window))
1323
1324 (defbinding window-group-remove-window () nil
1325   (window-group window-group)
1326   (window window))
1327
1328
1329 ;;; Scrolled window
1330
1331 (defun (setf scrolled-window-scrollbar-policy) (policy window)
1332   (setf (scrolled-window-hscrollbar-policy window) policy)
1333   (setf (scrolled-window-vscrollbar-policy window) policy))
1334
1335 (defbinding scrolled-window-add-with-viewport () nil
1336    (scrolled-window scrolled-window)
1337    (child widget))
1338
1339 (defmethod initialize-instance ((window scrolled-window) &rest initargs
1340                                 &key policy)
1341   (if policy
1342       (apply #'call-next-method window
1343        :vscrollbar-policy policy :hscrollbar-policy policy initargs)
1344     (call-next-method)))
1345
1346
1347 ;;; Statusbar
1348
1349 (defbinding statusbar-get-context-id () unsigned-int
1350   (statusbar statusbar)
1351   (context-description string))
1352
1353 (defbinding statusbar-push () unsigned-int
1354   (statusbar statusbar)
1355   (context-id unsigned-int)
1356   (text string))
1357
1358 (defbinding statusbar-pop () nil
1359   (statusbar statusbar)
1360   (context-id unsigned-int))
1361
1362 (defbinding statusbar-remove () nil
1363   (statusbar statusbar)
1364   (context-id unsigned-int)
1365   (message-id unsigned-int))
1366
1367
1368
1369 ;;; Fixed
1370
1371 (defbinding fixed-put () nil
1372   (fixed fixed)
1373   (widget widget)
1374   (x int) (y int))
1375
1376 (defbinding fixed-move () nil
1377   (fixed fixed)
1378   (widget widget)
1379   (x int) (y int))
1380
1381
1382
1383 ;;; Notebook
1384
1385 (defun %ensure-notebook-position (notebook page)
1386   (etypecase page
1387     (position page)
1388     (widget (notebook-page-num notebook page t))))
1389
1390 (defun %ensure-notebook-child (notebook position)
1391   (typecase position
1392      (widget position)
1393      (t (notebook-get-nth-page notebook position))))
1394
1395 (defbinding (notebook-insert "gtk_notebook_insert_page_menu")
1396     (notebook position child tab-label &optional menu-label) nil
1397   (notebook notebook)
1398   (child widget)
1399   ((if (stringp tab-label)
1400        (make-instance 'label :label tab-label)
1401      tab-label) widget)
1402   ((if (stringp menu-label)
1403        (make-instance 'label :label menu-label)
1404      menu-label) (or null widget))
1405   ((%ensure-notebook-position notebook position) position))
1406
1407 (defun notebook-append (notebook child tab-label &optional menu-label)
1408   (notebook-insert notebook :last child tab-label menu-label))
1409
1410 (defun notebook-prepend (notebook child tab-label &optional menu-label)
1411   (notebook-insert notebook :first child tab-label menu-label))
1412
1413 (defbinding notebook-remove-page (notebook page) nil
1414   (notebook notebook)
1415   ((%ensure-notebook-position notebook page) position))
1416
1417 (defbinding %notebook-page-num () int
1418   (notebook notebook)
1419   (child widget))
1420
1421 (defun notebook-page-num (notebook child &optional error-p)
1422   (let ((page-num (%notebook-page-num notebook child)))
1423     (if (= page-num -1)
1424         (when error-p
1425           (error "~A is not a page in ~A" child notebook))
1426       page-num)))
1427
1428 (defbinding notebook-next-page () nil
1429   (notebook notebook))
1430
1431 (defbinding notebook-prev-page () nil
1432   (notebook notebook))
1433
1434 (defbinding notebook-reorder-child (notebook child position) nil
1435   (notebook notebook)
1436   (child widget)
1437   ((%notebook-position notebook position) int))
1438
1439 (defbinding notebook-popup-enable () nil
1440   (notebook notebook))
1441
1442 (defbinding notebook-popup-disable () nil
1443   (notebook notebook))
1444
1445 (defbinding notebook-get-nth-page () widget
1446   (notebook notebook)
1447   (page position))
1448
1449 (defun %notebook-current-page (notebook)
1450   (when (slot-boundp notebook 'current-page-num)
1451     (notebook-get-nth-page notebook (notebook-current-page-num notebook))))
1452
1453 (defun (setf notebook-current-page) (page notebook)
1454   (setf (notebook-current-page notebook) (notebook-page-num notebook page)))
1455
1456 (defbinding (notebook-tab-label "gtk_notebook_get_tab_label")
1457     (notebook page) widget
1458   (notebook notebook)
1459   ((%ensure-notebook-child notebook page) widget))
1460
1461 (defbinding (notebook-tab-label-text "gtk_notebook_get_tab_label_text")
1462     (notebook page) (copy-of string)
1463   (notebook notebook)
1464   ((%ensure-notebook-child notebook page) widget))
1465
1466 (defbinding %notebook-set-tab-label () nil
1467   (notebook notebook)
1468   (page widget)
1469   (tab-label widget))
1470
1471 (defun (setf notebook-tab-label) (tab-label notebook page)
1472   (let ((widget (if (stringp tab-label)
1473                     (make-instance 'label :label tab-label)
1474                   tab-label)))
1475     (%notebook-set-tab-label notebook (%ensure-notebook-child notebook page) widget)
1476     widget))
1477
1478
1479 (defbinding (notebook-menu-label "gtk_notebook_get_menu_label")
1480     (notebook page) widget
1481   (notebook notebook)
1482   ((%ensure-notebook-child notebook page) widget))
1483
1484 (defbinding (notebook-menu-label-text "gtk_notebook_get_menu_label_text")
1485     (notebook page) (copy-of string)
1486   (notebook notebook)
1487   ((%ensure-notebook-child notebook page) widget))
1488
1489 (defbinding %notebook-set-menu-label () nil
1490   (notebook notebook)
1491   (page widget)
1492   (menu-label widget))
1493
1494 (defun (setf notebook-menu-label) (menu-label notebook page)
1495   (let ((widget (if (stringp menu-label)
1496                     (make-instance 'label :label menu-label)
1497                   menu-label)))
1498     (%notebook-set-menu-label notebook (%ensure-notebook-child notebook page) widget)
1499     widget))
1500
1501
1502 (defbinding notebook-query-tab-label-packing (notebook page) nil
1503   (notebook notebook)
1504   ((%notebook-child notebook page) widget)
1505   (expand boolean :out)
1506   (fill boolean :out)
1507   (pack-type pack-type :out))
1508
1509 (defbinding notebook-set-tab-label-packing
1510     (notebook page expand fill pack-type) nil
1511   (notebook notebook)
1512   ((%notebook-child notebook page) widget)
1513   (expand boolean)
1514   (fill boolean)
1515   (pack-type pack-type))
1516
1517
1518
1519 ;;; Paned
1520
1521 (defbinding paned-pack1 () nil
1522   (paned paned)
1523   (child widget)
1524   (resize boolean)
1525   (shrink boolean))
1526
1527 (defbinding paned-pack2 () nil
1528   (paned paned)
1529   (child widget)
1530   (resize boolean)
1531   (shrink boolean))
1532
1533
1534 ;;; Layout
1535
1536 (defbinding layout-put () nil
1537   (layout layout)
1538   (child widget)
1539   (x int)
1540   (y int))
1541
1542 (defbinding layout-move () nil
1543   (layout layout)
1544   (child widget)
1545   (x int)
1546   (y int))
1547
1548 (defbinding layout-set-size () nil
1549   (layout layout)
1550   (width unsigned-int)
1551   (height unsigned-int))
1552
1553 (defbinding layout-get-size () nil
1554   (layout layout)
1555   (width unsigned-int :out)
1556   (height unsigned-int :out))
1557
1558
1559 ;;; Menu shell
1560
1561 (defbinding menu-shell-insert (menu-shell menu-item position) nil
1562   (menu-shell menu-shell)
1563   (menu-item menu-item)
1564   ((case position
1565      (:first 0)
1566      (:last -1)
1567      (t position)) int))
1568
1569 (defun menu-shell-append (menu-shell menu-item)
1570   (menu-shell-insert menu-shell menu-item :last))
1571
1572 (defun menu-shell-prepend (menu-shell menu-item)
1573   (menu-shell-insert menu-shell menu-item :fisrt))
1574
1575 (defbinding menu-shell-deactivate () nil
1576   (menu-shell menu-shell))
1577
1578 (defbinding menu-shell-select-item () nil
1579   (menu-shell menu-shell)
1580   (menu-item menu-item))
1581
1582 (defbinding menu-shell-select-first () nil
1583   (menu-shell menu-shell)
1584   (search-sensitive boolean))
1585
1586 (defbinding menu-shell-deselect () nil
1587   (menu-shell menu-shell))
1588
1589 (defbinding menu-shell-activate-item () nil
1590   (menu-shell menu-shell)
1591   (menu-item menu-item)
1592   (fore-deactivate boolean))
1593
1594 (defbinding menu-shell-cancel () nil
1595   (menu-shell menu-shell))
1596
1597
1598 ;;; Menu
1599
1600 (defun %menu-position (menu child)
1601   (etypecase child
1602     (int child)
1603     (keyword (case child
1604                (:first 0)
1605                (:last -1)
1606                (t (error "Invalid position keyword: ~A" child))))
1607     (widget (menu-child-position menu child))))
1608
1609
1610 (defbinding menu-reorder-child (menu menu-item position) nil
1611   (menu menu)
1612   (menu-item menu-item)
1613   ((%menu-position menu position) int))
1614
1615 (defbinding menu-attach () nil
1616   (menu menu)
1617   (menu-item menu-item)
1618   (left-attach unsigned-int)
1619   (right-attach unsigned-int)
1620   (top-attach unsigned-int)
1621   (bottom-attach unsigned-int))
1622
1623 (def-callback-marshal %menu-position-func (nil (menu menu) (x int) (y int) (push-in boolean)))
1624
1625 (defbinding %menu-popup () nil
1626   (menu menu)
1627   (parent-menu-shell (or null menu-shell))
1628   (parent-menu-item (or null menu-item))
1629   (callback-func (or null pointer))
1630   (callback-id unsigned-int)
1631   (button unsigned-int)
1632   (activate-time (unsigned 32)))
1633
1634 (defun menu-popup (menu button activate-time &key callback parent-menu-shell
1635                    parent-menu-item)
1636   (if callback
1637       (with-callback-function (id callback)
1638         (%menu-popup
1639          menu parent-menu-shell parent-menu-item
1640          (callback %menu-position-func) id button activate-time))
1641     (%menu-popup
1642      menu parent-menu-shell parent-menu-item nil 0 button activate-time)))
1643
1644 (defbinding menu-set-accel-path () nil
1645   (menu menu)
1646   (accel-path string))
1647
1648 (defbinding menu-reposition () nil
1649   (menu menu))
1650
1651 (defbinding menu-popdown () nil
1652   (menu menu))
1653
1654 (defun menu-child-position (menu child)
1655   (position child (container-children menu)))
1656
1657 (defun menu-active-num (menu)
1658   (menu-child-position menu (menu-active menu)))
1659
1660 (defbinding %menu-set-active () nil
1661   (menu menu)
1662   (index unsigned-int))
1663
1664 (defun (setf menu-active) (menu child)
1665   (%menu-set-active menu (%menu-position menu child))
1666   child)
1667
1668 (defcallback %menu-detach-func (nil (widget widget) (menu menu))
1669   (funcall (object-data menu 'detach-func) widget menu))
1670
1671 (defbinding %menu-attach-to-widget () nil
1672   (menu menu)
1673   (widget widget)
1674   ((callback %menu-detach-func) pointer))
1675
1676 (defun menu-attach-to-widget (menu widget function)
1677   (setf (object-data menu 'detach-func) function)
1678   (%menu-attach-to-widget menu widget))
1679
1680 (defbinding menu-detach () nil
1681   (menu menu))
1682
1683 #+gtk2.6
1684 (defbinding menu-get-for-attach-widget () (copy-of (glist widget))
1685   (widget widget))
1686
1687 (defbinding menu-set-monitor () nil
1688   (menu menu)
1689   (monitor-num int))
1690
1691
1692 ;;; Table
1693
1694 (defbinding table-resize () nil
1695   (table table)
1696   (rows unsigned-int)
1697   (columns unsigned-int))
1698
1699 (defbinding table-attach (table child left right top bottom
1700                           &key options x-options y-options
1701                           (x-padding 0) (y-padding 0)) nil
1702   (table table)
1703   (child widget)
1704   (left unsigned-int)
1705   (right unsigned-int)
1706   (top unsigned-int)
1707   (bottom unsigned-int)
1708   ((append (mklist options) (mklist x-options)) attach-options)
1709   ((append (mklist options) (mklist y-options)) attach-options)
1710   (x-padding unsigned-int)
1711   (y-padding unsigned-int))
1712
1713
1714 (defbinding %table-set-row-spacing () nil
1715   (table table)
1716   (row unsigned-int)
1717   (spacing unsigned-int))
1718
1719 (defbinding %table-set-row-spacings () nil
1720   (table table)
1721   (spacing unsigned-int))
1722
1723 (defun (setf table-row-spacing) (spacing table &optional row)
1724   (if row
1725       (%table-set-row-spacing table row spacing)
1726     (%table-set-row-spacings table spacing))
1727   spacing)
1728
1729 (defbinding %table-get-row-spacing () unsigned-int
1730   (table table)
1731   (row unsigned-int))
1732
1733 (defbinding %table-get-default-row-spacing () unsigned-int
1734   (table table))
1735
1736 (defun table-row-spacing (table &optional row)
1737   (if row
1738       (%table-get-row-spacing table row)
1739     (%table-get-default-row-spacing table)))
1740
1741
1742 (defbinding %table-set-col-spacing () nil
1743   (table table)
1744   (col unsigned-int)
1745   (spacing unsigned-int))
1746
1747 (defbinding %table-set-col-spacings () nil
1748   (table table)
1749   (spacing unsigned-int))
1750
1751 (defun (setf table-col-spacing) (spacing table &optional col)
1752   (if col
1753       (%table-set-col-spacing table col spacing)
1754     (%table-set-col-spacings table spacing))
1755   spacing)
1756
1757 (defbinding %table-get-col-spacing () unsigned-int
1758   (table table)
1759   (col unsigned-int))
1760
1761 (defbinding %table-get-default-col-spacing () unsigned-int
1762   (table table))
1763
1764 (defun table-col-spacing (table &optional col)
1765   (if col
1766       (%table-get-col-spacing table col)
1767     (%table-get-default-col-spacing table)))
1768
1769
1770
1771 ;;; Toolbar
1772
1773 (defmethod initialize-instance ((toolbar toolbar) &rest initargs &key tooltips)
1774   (if (eq tooltips t)
1775       (apply #'call-next-method toolbar
1776        :tooltips (make-instance 'tooltips) initargs)
1777     (call-next-method)))
1778
1779 (defbinding %toolbar-insert () nil
1780   (toolbar toolbar)
1781   (tool-item tool-item)
1782   (position position))
1783
1784 (defun toolbar-insert (toolbar tool-item &optional (position :end))
1785   (%toolbar-insert toolbar tool-item position)
1786   (%tool-item-update-tooltips tool-item))
1787
1788 (defbinding toolbar-get-item-index () int
1789   (toolbar toolbar)
1790   (item tool-item))
1791
1792 (defbinding toolbar-get-nth-item () tool-item
1793   (toolbar toolbar)
1794   (n int))
1795
1796 (defbinding toolbar-get-drop-index () int
1797   (toolbar toolbar)
1798   (x int) (y int))
1799
1800 (defbinding toolbar-set-drop-highlight-item () nil
1801   (toolbar toolbar)
1802   (tool-item tool-item)
1803   (index int))
1804
1805
1806 ;;; Tool button
1807
1808 (defmethod initialize-instance ((button tool-button) &rest initargs &key icon)
1809   (if (and icon (not (typep icon 'widget)))
1810       (apply #'call-next-method button :icon (create-image-widget icon) initargs)
1811     (call-next-method)))
1812
1813
1814 ;;; Tool item
1815
1816 (defbinding tool-item-set-tooltip () nil
1817   (tool-item tool-item)
1818   (tooltips tooltips)
1819   (tip-text string)
1820   (tip-private string))
1821
1822
1823 (defun %tool-item-update-tooltips (tool-item)
1824   (when (and
1825          (slot-boundp tool-item 'parent)
1826          (or
1827           (user-data-p tool-item 'tip-text)
1828           (user-data-p tool-item 'tip-private)))
1829     (tool-item-set-tooltip
1830      tool-item (toolbar-tooltips (widget-parent tool-item))
1831      (or (user-data tool-item 'tip-text) "")
1832      (or (user-data tool-item 'tip-private) ""))))
1833
1834 (defmethod (setf tool-item-tip-text) ((tip-text string) (tool-item tool-item))
1835   (setf (user-data tool-item 'tip-text) tip-text)
1836   (%tool-item-update-tooltips tool-item)
1837   tip-text)
1838
1839 (defmethod (setf tool-item-tip-private) ((tip-private string) (tool-item tool-item))
1840   (setf (user-data tool-item 'tip-private) tip-private)
1841   (%tool-item-update-tooltips tool-item)
1842   tip-private)
1843
1844 (defmethod container-add ((toolbar toolbar) (tool-item tool-item) &rest args)
1845   (declare (ignore args))
1846   (prog1
1847       (call-next-method)
1848     (%tool-item-update-tooltips tool-item)))
1849
1850
1851 (defbinding tool-item-retrieve-proxy-menu-item () widget
1852   (tool-item tool-item))
1853
1854 (defbinding (tool-item-proxy-menu-item
1855              "gtk_tool_item_get_proxy_menu_item") () menu-item
1856   (tool-item tool-item)
1857   (menu-item-id string))
1858
1859 (defbinding %tool-item-set-proxy-menu-item () nil
1860   (tool-item tool-item)
1861   (menu-item-id string)
1862   (menu-item menu-item))
1863
1864 (defun (setf tool-item-proxy-menu-item) (menu-item menu-item-id tool-item)
1865   (%tool-item-set-proxy-menu-item menu-item-id tool-item menu-item)
1866    menu-item)
1867
1868 #+gtk2.6
1869 (defbinding tool-item-rebuild-menu () nil
1870   (tool-item tool-item))
1871
1872
1873 ;;; Editable
1874
1875 (defbinding editable-select-region (editable &optional (start 0) end) nil
1876   (editable editable)
1877   (start int)
1878   ((or end -1) int))
1879
1880 (defbinding editable-get-selection-bounds (editable) nil
1881   (editable editable)
1882   (start int :out)
1883   (end int :out))
1884
1885 (defbinding editable-insert-text (editable text &optional (position 0)) nil
1886   (editable editable)
1887   (text string)
1888   ((length text) int)
1889   (position position :in-out))
1890
1891 (defun editable-append-text (editable text)
1892   (editable-insert-text editable text nil))
1893
1894 (defun editable-prepend-text (editable text)
1895   (editable-insert-text editable text 0))
1896
1897 (defbinding editable-delete-text (editable &optional (start 0) end) nil
1898   (editable editable)
1899   (start int)
1900   ((or end -1) int))
1901
1902 (defbinding (editable-text "gtk_editable_get_chars")
1903     (editable &optional (start 0) end) string
1904   (editable editable)
1905   (start int)
1906   ((or end -1) int))
1907
1908 (defun (setf editable-text) (text editable)
1909   (if text
1910       (editable-delete-text
1911        editable
1912        (editable-insert-text editable text))
1913     (editable-delete-text editable))
1914   text)
1915
1916 (defbinding editable-cut-clipboard () nil
1917   (editable editable))
1918
1919 (defbinding editable-copy-clipboard () nil
1920   (editable editable))
1921
1922 (defbinding editable-paste-clipboard () nil
1923   (editable editable))
1924
1925 (defbinding editable-delete-selection () nil
1926   (editable editable))
1927
1928
1929
1930 ;;; Spin button
1931
1932 (defbinding spin-button-configure () nil
1933   (spin-button spin-button)
1934   (adjustment adjustment)
1935   (climb-rate double-float)
1936   (digits unsigned-int))
1937
1938 (defbinding spin-button-set-range () nil
1939   (spin-button spin-button)
1940   (min double-float)
1941   (max double-float))
1942
1943 (defbinding spin-button-get-range () nil
1944   (spin-button spin-button)
1945   (min double-float :out)
1946   (max double-float :out))
1947
1948 (defun spin-button-value-as-int (spin-button)
1949   (round (spin-button-value spin-button)))
1950
1951 (defbinding spin-button-spin () nil
1952   (spin-button spin-button)
1953   (direction spin-type)
1954   (increment single-float))
1955
1956 (defbinding spin-button-update () nil
1957   (spin-button spin-button))
1958
1959
1960
1961 ; ;;; Ruler
1962
1963 (defbinding ruler-set-range () nil
1964   (ruler ruler)
1965   (lower single-float)
1966   (upper single-float)
1967   (position single-float)
1968   (max-size single-float))
1969
1970 (defbinding ruler-get-range () nil
1971   (ruler ruler)
1972   (lower single-float :out)
1973   (upper single-float :out)
1974   (position single-float :out)
1975   (max-size single-float :out))
1976
1977
1978
1979 ;;; Range
1980
1981 (defun range-lower (range)
1982   (adjustment-lower (range-adjustment range)))
1983
1984 (defun range-upper (range)
1985   (adjustment-upper (range-adjustment range)))
1986
1987 (defun (setf range-lower) (value range)
1988   (setf (adjustment-lower (range-adjustment range)) value))
1989
1990 (defun (setf range-upper) (value range)
1991   (setf (adjustment-upper (range-adjustment range)) value))
1992
1993 (defun range-page-increment (range)
1994   (adjustment-page-increment (range-adjustment range)))
1995
1996 (defun range-step-increment (range)
1997   (adjustment-step-increment (range-adjustment range)))
1998
1999 (defun (setf range-page-increment) (value range)
2000   (setf (adjustment-page-increment (range-adjustment range)) value))
2001
2002 (defun (setf range-step-increment) (value range)
2003   (setf (adjustment-step-increment (range-adjustment range)) value))
2004
2005 (defbinding range-set-range () nil
2006   (range range)
2007   (lower double-float)
2008   (upper double-float))
2009
2010 (defbinding range-set-increments () nil
2011   (range range)
2012   (step double-float)
2013   (page double-float))
2014
2015
2016 ;;; Scale
2017
2018 (defbinding scale-get-layout-offsets () nil
2019   (scale scale)
2020   (x int :out)
2021   (y int :out))
2022
2023
2024 ;;; Progress bar
2025
2026 (defbinding progress-bar-pulse () nil
2027   (progress-bar progress-bar))
2028
2029
2030 ;;; Size group
2031
2032 (defmethod initialize-instance ((size-group size-group) &rest initargs
2033                                 &key widget widgets)
2034   (declare (ignore widget widgets))
2035   (prog1
2036       (call-next-method)
2037     (initial-add size-group #'size-group-add-widget
2038      initargs :widget :widgets)))
2039
2040
2041 (defbinding size-group-add-widget () nil
2042   (size-group size-group)
2043   (widget widget))
2044
2045 (defbinding size-group-remove-widget () nil
2046   (size-group size-group)
2047   (widget widget))
2048
2049
2050 ;;; Stock items
2051
2052 (defbinding %stock-item-copy () pointer
2053   (location pointer))
2054
2055 (defbinding %stock-item-free () nil
2056   (location pointer))
2057
2058 (defmethod reference-foreign ((class (eql (find-class 'stock-item))) location)
2059   (%stock-item-copy location))
2060
2061 (defmethod unreference-foreign ((class (eql (find-class 'stock-item))) location)
2062   (%stock-item-free location))
2063
2064 (defbinding stock-add (stock-item) nil
2065   (stock-item stock-item)
2066   (1 unsigned-int))
2067
2068 (defbinding stock-list-ids () (gslist string))
2069
2070 (defbinding %stock-lookup () boolean
2071   (stock-id string)
2072   (location pointer))
2073
2074 (defun stock-lookup (stock-id)
2075   (let ((location
2076          (allocate-memory (proxy-instance-size (find-class 'stock-item)))))
2077     (unwind-protect
2078         (when (%stock-lookup stock-id location)
2079           (ensure-proxy-instance 'stock-item (%stock-item-copy location)))
2080         (deallocate-memory location))))
2081
2082
2083 ;;; Tooltips
2084
2085 (defbinding tooltips-enable () nil
2086   (tooltips tooltips))
2087
2088 (defbinding tooltips-disable () nil
2089   (tooltips tooltips))
2090
2091 (defun (setf tooltips-enabled-p) (enable tooltips)
2092   (if enable
2093       (tooltips-enable tooltips)
2094     (tooltips-disable tooltips)))
2095
2096 (defbinding tooltips-set-tip () nil
2097   (tooltips tooltips)
2098   (widget widget)
2099   (tip-text string)
2100   (tip-private string))
2101
2102 (defbinding tooltips-data-get () tooltips-data
2103   (widget widget))
2104
2105 (defbinding tooltips-force-window () nil
2106   (tooltips tooltips))
2107
2108 (defbinding tooltips-get-info-from-tip-window () boolean
2109   (tip-window window)
2110   (tooltips tooltips :out)
2111   (current-widget widget :out))
2112
2113
2114 ;;; Rc
2115
2116 (defbinding rc-add-default-file (filename) nil
2117   ((namestring (truename filename)) string))
2118
2119 (defbinding rc-parse (filename) nil
2120   ((namestring (truename filename)) string))
2121
2122 (defbinding rc-parse-string () nil
2123   (rc-string string))
2124
2125 (defbinding rc-reparse-all () nil)
2126
2127 (defbinding rc-get-style () style
2128   (widget widget))