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

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