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