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