chiark - git - mdw - clg/blob - gtk/gtk.lisp

   1 ;; Common Lisp bindings for GTK+ v2.x
   2 ;; Copyright 1999-2006 Espen S. Johnsen <espen@users.sf.net>
   3 ;;
   4 ;; Permission is hereby granted, free of charge, to any person obtaining
   5 ;; a copy of this software and associated documentation files (the
   6 ;; "Software"), to deal in the Software without restriction, including
   7 ;; without limitation the rights to use, copy, modify, merge, publish,
   8 ;; distribute, sublicense, and/or sell copies of the Software, and to
   9 ;; permit persons to whom the Software is furnished to do so, subject to
  10 ;; the following conditions:
  11 ;;
  12 ;; The above copyright notice and this permission notice shall be
  13 ;; included in all copies or substantial portions of the Software.
  14 ;;
  15 ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  16 ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
  17 ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
  18 ;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
  19 ;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
  20 ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
  21 ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
  22
  23 ;; $Id: gtk.lisp,v 1.73 2007-06-19 11:32:25 espen Exp $
  24
  25
  26 (in-package "GTK")
  27
  28 ;;; Gtk version
  29
  30 (defbinding check-version () (copy-of string)
  31   (required-major unsigned-int)
  32   (required-minor unsigned-int)
  33   (required-micro unsigned-int))
  34
  35 (defbinding query-version () nil
  36   (major unsigned-int :out)
  37   (minor unsigned-int :out)
  38   (micro unsigned-int :out))
  39
  40 (defun gtk-version ()
  41   (multiple-value-bind (major minor micro)
  42       (query-version)
  43     (if (zerop micro)
  44         (format nil "Gtk+ v~A.~A" major minor)
  45       (format nil "Gtk+ v~A.~A.~A" major minor micro))))
  46
  47 (defun clg-version ()
  48   "clg 0.93")
  49
  50
  51 ;;;; Initalization and display handling
  52
  53 (defparameter *event-poll-interval* 10000) ; in microseconds
  54
  55
  56 (defbinding (gtk-init "gtk_parse_args") () boolean
  57   "Initializes the library without opening the display."
  58   (nil null)
  59   (nil null))
  60
  61 (defun clg-init (&optional display multi-threading-p)
  62   "Initializes the system and starts event handling."
  63   (unless (gdk:display-get-default)
  64     #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.8.0")
  65     (progn
  66       #+sbcl(sb-int:set-floating-point-modes :traps nil)
  67       #+cmu(ext:set-floating-point-modes :traps nil))
  68
  69      (gdk:gdk-init)
  70      (unless (gtk-init)
  71        (error "Initialization of GTK+ failed."))
  72
  73     (if (not multi-threading-p)
  74         (%init-async-event-handling display)
  75       #+sb-thread(%init-multi-threaded-event-handling display)
  76       #-sb-thread(error "Multi threading not supported on this platform")))
  77   (gdk:find-display display))
  78
  79 (defun clg-init-with-threading (&optional display)
  80   (clg-init display t))
  81
  82
  83 #?(sbcl>= 1 0 6)
  84 ;; A very minimal implementation of CLISP's socket-status
  85 (defun socket-status (socket seconds microseconds)
  86   (sb-alien:with-alien ((read-fds (sb-alien:struct sb-unix:fd-set)))
  87     (let ((fd (sb-sys:fd-stream-fd (car socket))))
  88       (sb-unix:fd-zero read-fds)
  89       (sb-unix:fd-set fd read-fds)
  90
  91       (unless (zerop (sb-unix:unix-fast-select
  92                       (1+ fd) (sb-alien:addr read-fds) nil nil
  93                       seconds microseconds))
  94         (if (peek-char nil (car socket) nil)
  95             :input
  96           :eof)))))
  97
  98 (defun %init-async-event-handling (display)
  99   (let ((style #?(or (featurep :cmu) (sbcl< 1 0 6)) :fd-handler
 100                #?-(or (featurep :cmu) (sbcl< 1 0 6)) nil))
 101     (when (and
 102            (find-package "SWANK")
 103            (not (eq (symbol-value (find-symbol "*COMMUNICATION-STYLE*" "SWANK")) style)))
 104       (error "When running clg in Slime, the communication style ~A must be used in combination with asynchronous event handling on this platform. See the README file and <http://common-lisp.net/project/slime/doc/html/slime_45.html> for more information." style)))
 105
 106   #?(or (featurep :cmu) (sbcl< 1 0 6))
 107   (progn
 108     (signal-connect (gdk:display-manager) 'display-opened
 109      #'(lambda (display)
 110          (let ((fd (gdk:display-connection-number display)))
 111            (unless (< fd 0)
 112              (let ((handler (add-fd-handler
 113                              (gdk:display-connection-number display)
 114                              :input #'main-iterate-all)))
 115                (signal-connect display 'closed
 116                 #'(lambda (is-error-p)
 117                     (declare (ignore is-error-p))
 118                     (remove-fd-handler handler))))))))
 119     (setq *periodic-polling-function* #'main-iterate-all)
 120     (setq *max-event-to-sec* 0)
 121     (setq *max-event-to-usec* *event-poll-interval*))
 122
 123   #+(and clisp readline)
 124   ;; Readline will call the event hook at most ten times per second
 125   (setf readline:event-hook #'main-iterate-all)
 126
 127   #?-(or (featurep :cmu) (sbcl< 1 0 6))
 128   ;; When running in Slime we need to hook into the Swank server
 129   ;; to handle events asynchronously.
 130   (if (find-package "SWANK")
 131       (let ((read-from-emacs (symbol-function (find-symbol "READ-FROM-EMACS" "SWANK")))
 132             (stream (funcall (find-symbol "CONNECTION.SOCKET-IO" "SWANK") (symbol-value (find-symbol "*EMACS-CONNECTION*" "SWANK")))))
 133         (setf (symbol-function (find-symbol "READ-FROM-EMACS" "SWANK"))
 134          #'(lambda ()
 135              (loop
 136               (case (socket-status (cons stream :input) 0 *event-poll-interval*)
 137                 ((:input :eof) (return (funcall read-from-emacs)))
 138                 (otherwise (main-iterate-all)))))))
 139     #-(and clisp readline)
 140     (warn "Asynchronous event handling not supported on this platform. An explicit main loop has to be started."))
 141
 142   (gdk:display-open display))
 143
 144 #+sb-thread
 145 (progn
 146   (defvar *main-thread* nil)
 147
 148   ;; Hopefully, when threading support is added to the Win32 port of
 149   ;; SBCL in the future, this will work just out of the box.
 150   #+win32
 151   (let ((done (sb-thread:make-waitqueue))
 152         (functions ())
 153         (results ()))
 154
 155     ;; In Win32 all GDK calls have to be made from the main loop
 156     ;; thread, so we add a timeout function which will poll for code and
 157     ;; execute it.
 158
 159     (defun funcall-in-main (function)
 160       (if (or
 161            (not *main-thread*)
 162            (eq sb-thread:*current-thread* *main-thread*))
 163           (funcall function)
 164         (gdk:with-global-lock
 165           (push function functions)
 166           (sb-thread:condition-wait done gdk:*global-lock*)
 167           (pop results))))
 168
 169     ;; Will lock REPL on error, need to be fixed!
 170     (defun %funcall-in-main-poll ()
 171       (when functions
 172         (loop
 173          for n from 0
 174          while functions
 175          do (push (funcall (pop functions)) results)
 176          finally (sb-thread:condition-notify done n)))
 177       t))
 178
 179   (defmacro within-main-loop (&body body)
 180     #-win32 `(gdk:with-global-lock ,@body)
 181     #+win32 `(funcall-in-main #'(lambda () ,@body)))
 182
 183   (defun %init-multi-threaded-event-handling (display)
 184     (when (and
 185            (find-package "SWANK")
 186            (not (eq (symbol-value (find-symbol "*COMMUNICATION-STYLE*" "SWANK")) :spawn)))
 187       (error "When running clg in Slime, the communication style :spawn must be used in combination with multi threaded event handling. See the README file and <http://common-lisp.net/project/slime/doc/html/slime_45.html> for more information."))
 188     (let ((main-running (sb-thread:make-waitqueue)))
 189       (gdk:with-global-lock
 190        (setf *main-thread*
 191         (sb-thread:make-thread
 192          #'(lambda ()
 193              (gdk:threads-init)
 194              (gdk:with-global-lock
 195                (gdk:display-open display)
 196                #+win32(gdk:timeout-add-with-lock (/ *event-poll-interval* 1000)
 197                        #'%funcall-in-main-poll)
 198                (sb-thread:condition-notify main-running)
 199                (main)))
 200          :name "gtk event loop"))
 201         (sb-thread:condition-wait main-running gdk:*global-lock*)))
 202
 203     ;; We need to hook into the Swank server to protect calls to GDK properly.
 204     ;; This will *only* protect code entered directly in the REPL.
 205     (when (find-package "SWANK")
 206       (push #'(lambda (form)
 207                 (within-main-loop (eval form)))
 208        swank::*slime-repl-eval-hooks*))))
 209
 210 #-sb-thread
 211 (defmacro within-main-loop (&body body)
 212   `(progn ,@body))
 213
 214
 215
 216 ;;; Generic functions
 217
 218 (defgeneric add-to-radio-group (item1 item2))
 219 (defgeneric activate-radio-widget (item))
 220 (defgeneric (setf tool-item-tip-text) (tip-text tool-item))
 221 (defgeneric (setf tool-item-tip-private) (tip-private tool-item))
 222
 223
 224
 225 ;;; Misc
 226
 227 (defbinding grab-add () nil
 228   (widget widget))
 229
 230 (defbinding grab-get-current () widget)
 231
 232 (defbinding grab-remove () nil
 233   (widget widget))
 234
 235 (defbinding get-default-language () (copy-of pango:language))
 236
 237
 238 ;;; About dialog
 239
 240 #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0")
 241 (progn
 242   (define-callback-marshal %about-dialog-activate-link-callback nil
 243     (about-dialog (link string)))
 244
 245   (defbinding about-dialog-set-email-hook (function) nil
 246     (%about-dialog-activate-link-callback callback)
 247     ((register-callback-function function) unsigned-int)
 248     (user-data-destroy-callback callback))
 249
 250   (defbinding about-dialog-set-url-hook (function) nil
 251     (%about-dialog-activate-link-callback callback)
 252     ((register-callback-function function) unsigned-int)
 253     (user-data-destroy-callback callback)))
 254
 255
 256 ;;; Acccel group
 257
 258 (defbinding %accel-group-connect () nil
 259   (accel-group accel-group)
 260   (key unsigned-int)
 261   (modifiers gdk:modifier-type)
 262   (flags accel-flags)
 263   (gclosure gclosure))
 264
 265 (defun accel-group-connect (group accelerator function &optional flags)
 266   (multiple-value-bind (key modifiers) (parse-accelerator accelerator)
 267     (let ((gclosure (make-callback-closure function)))
 268       (%accel-group-connect group key modifiers flags gclosure)
 269       gclosure)))
 270
 271 (defbinding accel-group-connect-by-path (group path function) nil
 272   (group accel-group)
 273   (path string)
 274   ((make-callback-closure function) gclosure :in/return))
 275
 276 (defbinding %accel-group-disconnect (group gclosure) boolean
 277   (group accel-group)
 278   (gclosure gclosure))
 279
 280 (defbinding %accel-group-disconnect-key () boolean
 281   (group accel-group)
 282   (key unsigned-int)
 283   (modifiers gdk:modifier-type))
 284
 285 (defun accel-group-disconnect (group accelerator)
 286   (etypecase accelerator
 287     (gclosure (%accel-group-disconnect group accelerator))
 288     (string
 289      (multiple-value-bind (key modifiers) (parse-accelerator accelerator)
 290        (%accel-group-disconnect-key group key modifiers)))))
 291
 292 (defbinding %accel-group-query () (copy-of (vector (inlined accel-group-entry) n))
 293   (accel-group accel-group)
 294   (key unsigned-int)
 295   (modifiers gdk:modifier-type)
 296   (n int :out))
 297
 298 (defun accel-group-query (accel-group accelerator)
 299   (multiple-value-bind (key modifiers) (parse-accelerator accelerator)
 300     (%accel-group-query accel-group key modifiers)))
 301
 302 (defbinding %accel-group-activate () boolean
 303   (accel-group accel-group)
 304   (acceleratable gobject)
 305   (key unsigned-int)
 306   (modifiers gdk:modifier-type))
 307
 308 (defun accel-group-activate (accel-group acceleratable accelerator)
 309   (multiple-value-bind (key modifiers) (parse-accelerator accelerator)
 310     (%accel-group-activate accel-group acceleratable key modifiers)))
 311
 312 (defbinding accel-group-lock () nil
 313   (accel-group accel-group))
 314
 315 (defbinding accel-group-unlock () nil
 316   (accel-group accel-group))
 317
 318 (defbinding accel-group-from-accel-closure () accel-group
 319   (closure gclosure))
 320
 321 (defbinding %accel-groups-activate () boolean
 322   (object gobject)
 323   (key unsigned-int)
 324   (modifiers gdk:modifier-type))
 325
 326 (defun accel-groups-activate (object accelerator)
 327   (multiple-value-bind (key modifiers) (parse-accelerator accelerator)
 328     (%accel-groups-activate object key modifiers)))
 329
 330 (defbinding accel-groups-from-object () (gslist accel-groups)
 331   (object gobject))
 332
 333 (defbinding accelerator-valid-p (key &optional modifiers) boolean
 334   (key unsigned-int)
 335   (modifiers gdk:modifier-type))
 336
 337 (defbinding %accelerator-parse () nil
 338   (accelerator string)
 339   (key unsigned-int :out)
 340   (modifiers gdk:modifier-type :out))
 341
 342 (defgeneric parse-accelerator (accelerator))
 343
 344 (defmethod parse-accelerator ((accelerator string))
 345   (multiple-value-bind (key modifiers) (%accelerator-parse accelerator)
 346     (if (zerop key)
 347         (error "Invalid accelerator: ~A" accelerator)
 348       (values key modifiers))))
 349
 350 (defmethod parse-accelerator ((accelerator cons))
 351   (destructuring-bind (key modifiers) accelerator
 352     (values
 353      (etypecase key
 354        (integer key)
 355        (string
 356         (or
 357          (gdk:keyval-from-name key)
 358          (error "Invalid key name: ~A" key)))
 359        (character (parse-accelerator key)))
 360      modifiers)))
 361
 362 (defmethod parse-accelerator ((key integer))
 363   key)
 364
 365 (defmethod parse-accelerator ((key character))
 366   (or
 367    (gdk:keyval-from-name (string key))
 368    (error "Invalid key name: ~A" key)))
 369
 370
 371 (defbinding accelerator-name () string
 372   (key unsigned-int)
 373   (modifiers gdk:modifier-type))
 374
 375 #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0")
 376 (defbinding accelerator-get-label () string
 377   (key unsigned-int)
 378   (modifiers gdk:modifier-type))
 379
 380 (defbinding %accelerator-set-default-mod-mask () nil
 381   (default-modifiers gdk:modifier-type))
 382
 383 (defun (setf accelerator-default-modifier-mask) (default-modifiers)
 384   (%accelerator-set-default-mod-mask default-modifiers))
 385
 386 (defbinding (accelerator-default-modifier-mask "gtk_accelerator_get_default_mod_mask") () gdk:modifier-type)
 387
 388
 389 ;;; Acccel label
 390
 391 (defbinding accel-label-get-accel-width () unsigned-int
 392   (accel-label accel-label))
 393
 394 (defbinding accel-label-refetch () boolean
 395   (accel-label accel-label))
 396
 397
 398
 399 ;;; Accel map
 400
 401 (defbinding %accel-map-add-entry () nil
 402   (path string)
 403   (key unsigned-int)
 404   (modifiers gdk:modifier-type))
 405
 406 (defun accel-map-add-entry (path accelerator)
 407   (multiple-value-bind (key modifiers) (parse-accelerator accelerator)
 408     (%accel-map-add-entry path key modifiers)))
 409
 410 (defbinding %accel-map-lookup-entry () boolean
 411   (path string)
 412   ((make-instance 'accel-key) accel-key :in/return))
 413
 414 (defun accel-map-lookup-entry (path)
 415   (multiple-value-bind (found-p accel-key) (%accel-map-lookup-entry path)
 416     (when found-p
 417       (values
 418        (slot-value accel-key 'key)
 419        (slot-value accel-key 'modifiers)
 420        (slot-value accel-key 'flags)))))
 421
 422 (defbinding %accel-map-change-entry () boolean
 423   (path string)
 424   (key unsigned-int)
 425   (modifiers gdk:modifier-type)
 426   (replace boolean))
 427
 428 (defun accel-map-change-entry (path accelerator &optional replace)
 429   (multiple-value-bind (key modifiers) (parse-accelerator accelerator)
 430     (%accel-map-change-entry path key modifiers replace)))
 431
 432 (defbinding accel-map-load () nil
 433   (filename pathname))
 434
 435 (defbinding accel-map-save () nil
 436   (filename pathname))
 437
 438 (define-callback-marshal %accel-map-foreach-callback nil
 439   ((accel-path string) (key unsigned-int)
 440    (modifiers gdk:modifier-type) (changed boolean)) :callback-id :first)
 441
 442 (defbinding %accel-map-foreach (callback-id) nil
 443   (callback-id unsigned-int)
 444   (%accel-map-foreach-callback callback))
 445
 446 (defbinding %accel-map-foreach-unfiltered (callback-id) nil
 447   (callback-id unsigned-int)
 448   (%accel-map-foreach-callback callback))
 449
 450 (defun accel-map-foreach (function &optional (filter-p t))
 451   (with-callback-function (id function)
 452     (if filter-p
 453         (%accel-map-foreach id)
 454       (%accel-map-foreach-unfiltered id))))
 455
 456 (defbinding accel-map-add-filter () nil
 457   (filter string))
 458
 459 (defbinding accel-map-get () accel-map)
 460
 461 (defbinding accel-map-lock-path () nil
 462   (path string))
 463
 464 (defbinding accel-map-unlock-path () nil
 465   (path string))
 466
 467
 468
 469 ;;; Accessibility
 470
 471 (defbinding accessible-connect-widget-destroyed () nil
 472   (accessible accessible))
 473
 474
 475 ;;; Adjustment
 476
 477 (defmethod initialize-instance ((adjustment adjustment) &key value)
 478   (prog1
 479       (call-next-method)
 480     ;; we need to make sure that the value is set last, otherwise it
 481     ;; may be outside current limits and ignored
 482     (when value
 483       (setf (slot-value adjustment 'value) value))))
 484
 485
 486 (defbinding adjustment-changed () nil
 487   (adjustment adjustment))
 488
 489 (defbinding adjustment-value-changed () nil
 490   (adjustment adjustment))
 491
 492 (defbinding adjustment-clamp-page () nil
 493   (adjustment adjustment)
 494   (lower single-float)
 495   (upper single-float))
 496
 497
 498 ;;; Alignment
 499
 500 (defbinding alignment-set () nil
 501   (alognment alignment)
 502   (x-align single-float)
 503   (y-align single-float)
 504   (x-scale single-float)
 505   (y-scale single-float))
 506
 507 (defbinding alignment-get-padding () nil
 508   (alognment alignment)
 509   (top unsigned-int :out)
 510   (bottom unsigned-int :out)
 511   (left unsigned-int :out)
 512   (right unsigned-int :out))
 513
 514 (defbinding alignment-set-padding () nil
 515   (alognment alignment)
 516   (top unsigned-int)
 517   (bottom unsigned-int)
 518   (left unsigned-int)
 519   (right unsigned-int))
 520
 521
 522 ;;; Aspect frame
 523
 524
 525 ;;; Bin
 526
 527 (defun (setf bin-child) (child bin)
 528   (when-bind (current-child (bin-child bin))
 529     (container-remove bin current-child))
 530   (container-add bin child)
 531   child)
 532
 533 (defmethod compute-signal-function ((bin bin) signal function object args)
 534   (declare (ignore signal))
 535   (if (eq object :child)
 536       #'(lambda (&rest emission-args)
 537           (apply function (bin-child bin) (nconc (rest emission-args) args)))
 538     (call-next-method)))
 539
 540
 541 ;;; Box
 542
 543 (defbinding box-pack-start () nil
 544   (box box)
 545   (child widget)
 546   (expand boolean)
 547   (fill boolean)
 548   (padding unsigned-int))
 549
 550 (defbinding box-pack-end () nil
 551   (box box)
 552   (child widget)
 553   (expand boolean)
 554   (fill boolean)
 555   (padding unsigned-int))
 556
 557 (defun box-pack (box child &key end (expand t) (fill t) (padding 0))
 558   (if end
 559       (box-pack-end box child expand fill padding)
 560     (box-pack-start box child expand fill padding)))
 561
 562 (defbinding box-reorder-child () nil
 563   (box box)
 564   (child widget)
 565   (position int))
 566
 567 (defbinding box-query-child-packing () nil
 568   (box box)
 569   (child widget)
 570   (expand boolean :out)
 571   (fill boolean :out)
 572   (padding unsigned-int :out)
 573   (pack-type pack-type :out))
 574
 575 (defbinding box-set-child-packing () nil
 576   (box box)
 577   (child widget)
 578   (expand boolean)
 579   (fill boolean)
 580   (padding unsigned-int)
 581   (pack-type pack-type))
 582
 583
 584
 585 ;;; Button
 586
 587 (defmethod initialize-instance ((button button) &rest initargs &key stock)
 588   (if stock
 589       (apply #'call-next-method button
 590        :label stock :use-stock t :use-underline t initargs)
 591     (call-next-method)))
 592
 593
 594 (defbinding button-pressed () nil
 595   (button button))
 596
 597 (defbinding button-released () nil
 598   (button button))
 599
 600 (defbinding button-clicked () nil
 601   (button button))
 602
 603 (defbinding button-enter () nil
 604   (button button))
 605
 606 (defbinding button-leave () nil
 607   (button button))
 608
 609
 610
 611 ;;; Calendar
 612
 613 (defbinding calendar-select-month () int
 614   (calendar calendar)
 615   (month unsigned-int)
 616   (year unsigned-int))
 617
 618 (defbinding calendar-select-day () nil
 619   (calendar calendar)
 620   (day unsigned-int))
 621
 622 (defbinding calendar-mark-day () int
 623   (calendar calendar)
 624   (day unsigned-int))
 625
 626 (defbinding calendar-unmark-day () int
 627   (calendar calendar)
 628   (day unsigned-int))
 629
 630 (defbinding calendar-clear-marks () nil
 631   (calendar calendar))
 632
 633 (defbinding calendar-get-date () nil
 634   (calendar calendar)
 635   (year unsigned-int :out)
 636   (month unsigned-int :out)
 637   (day unsigned-int :out))
 638
 639 (defbinding calendar-freeze () nil
 640   (calendar calendar))
 641
 642 (defbinding calendar-thaw () nil
 643   (calendar calendar))
 644
 645
 646 ;;; Check menu item
 647
 648 (defbinding check-menu-item-toggled () nil
 649   (check-menu-item check-menu-item))
 650
 651
 652 ;;; Color selection
 653
 654 (defbinding (color-selection-is-adjusting-p
 655              "gtk_color_selection_is_adjusting") () boolean
 656   (colorsel color-selection))
 657
 658
 659
 660 ;;; Color selection dialog -- no functions
 661
 662
 663
 664 ;;;; Combo Box
 665
 666 (defmethod initialize-instance ((combo-box combo-box) &rest initargs
 667                                 &key model content active)
 668   (remf initargs :active)
 669   (if model
 670       (apply #'call-next-method combo-box initargs)
 671     (progn
 672       (apply #'call-next-method combo-box
 673        :model (make-instance 'list-store :column-types '(string))
 674        initargs)
 675       (unless (typep combo-box 'combo-box-entry)
 676         (let ((cell (make-instance 'cell-renderer-text)))
 677           (cell-layout-pack combo-box cell :expand t)
 678           (cell-layout-add-attribute combo-box cell :text 0)))))
 679   (when content
 680     (mapc #'(lambda (text)
 681               (combo-box-append-text combo-box text))
 682           content))
 683   (when active
 684     (setf (combo-box-active combo-box) active)))
 685
 686
 687 ;; (defmethod shared-initialize :after ((combo-box combo-box) names &key active)
 688 ;;   (when active
 689 ;;     (signal-emit combo-box 'changed)))
 690
 691 (defbinding combo-box-append-text () nil
 692   (combo-box combo-box)
 693   (text string))
 694
 695 (defbinding combo-box-insert-text () nil
 696   (combo-box combo-box)
 697   (position int)
 698   (text string))
 699
 700 (defbinding combo-box-prepend-text () nil
 701   (combo-box combo-box)
 702   (text string))
 703
 704 #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0")
 705 (defbinding combo-box-get-active-text () string
 706   (combo-box combo-box))
 707
 708 (defbinding combo-box-popup () nil
 709   (combo-box combo-box))
 710
 711 (defbinding combo-box-popdown () nil
 712   (combo-box combo-box))
 713
 714
 715
 716 ;;;; Combo Box Entry
 717
 718 (defmethod initialize-instance ((combo-box-entry combo-box-entry) &key model)
 719   (call-next-method)
 720   (unless model
 721     (setf (combo-box-entry-text-column combo-box-entry) 0)))
 722
 723
 724 ;;;; Dialog
 725
 726 (defmethod shared-initialize ((dialog dialog) names &rest initargs
 727                               &key button buttons)
 728   (declare (ignore names button buttons))
 729   (prog1
 730       (call-next-method)
 731     (initial-apply-add dialog #'dialog-add-button initargs :button :buttons)))
 732
 733
 734 (defun dialog-response-id (dialog response &optional create-p error-p)
 735   "Returns a numeric response id"
 736   (if (typep response 'response-type)
 737       (response-type-to-int response)
 738     (let ((responses (user-data dialog 'responses)))
 739       (cond
 740        ((and responses (position response responses :test #'equal)))
 741        (create-p
 742        (cond
 743          (responses
 744           (vector-push-extend response responses)
 745           (1- (length responses)))
 746          (t
 747           (setf
 748            (user-data dialog 'responses)
 749            (make-array 1 :adjustable t :fill-pointer t
 750                        :initial-element response))
 751           0)))
 752       (error-p
 753        (error "Invalid response: ~A" response))))))
 754
 755 (defun dialog-find-response (dialog id)
 756   "Finds a symbolic response given a numeric id"
 757   (if (< id 0)
 758       (int-to-response-type id)
 759     (aref (user-data dialog 'responses) id)))
 760
 761
 762 (defmethod compute-signal-id ((dialog dialog) signal)
 763   (if (dialog-response-id dialog signal)
 764       (ensure-signal-id 'response dialog)
 765     (call-next-method)))
 766
 767 (defmethod compute-signal-function ((dialog dialog) signal function object args)
 768   (declare (ignore function object args))
 769   (let ((callback (call-next-method))
 770         (id (dialog-response-id dialog signal)))
 771     (if id
 772         #'(lambda (dialog response)
 773             (when (= response id)
 774               (funcall callback dialog)))
 775       callback)))
 776
 777 (defbinding dialog-run () nil
 778   (dialog dialog))
 779
 780 (defbinding dialog-response (dialog response) nil
 781   (dialog dialog)
 782   ((dialog-response-id dialog response nil t) int))
 783
 784
 785 (defbinding %dialog-add-button () button
 786   (dialog dialog)
 787   (text string)
 788   (response-id int))
 789
 790 (defun dialog-add-button (dialog label &optional (response label)
 791                           &key default object after)
 792   "Adds a button to the dialog."
 793   (let* ((signal (if (functionp response)
 794                      label
 795                    response))
 796          (id (dialog-response-id dialog signal t))
 797          (button (%dialog-add-button dialog label id)))
 798     (when (functionp response)
 799        (signal-connect dialog signal response :object object :after after))
 800     (when default
 801       (%dialog-set-default-response dialog id))
 802     button))
 803
 804
 805 (defbinding %dialog-add-action-widget () nil
 806   (dialog dialog)
 807   (action-widget widget)
 808   (response-id int))
 809
 810 (defun dialog-add-action-widget (dialog widget &optional (response widget)
 811                                  &key default object after)
 812   (let* ((signal (if (functionp response)
 813                      widget
 814                    response))
 815          (id (dialog-response-id dialog signal t)))
 816     (unless (widget-hidden-p widget)
 817       (widget-show widget))
 818     (%dialog-add-action-widget dialog widget id)
 819     (when (functionp response)
 820        (signal-connect dialog signal response :object object :after after))
 821     (when default
 822       (%dialog-set-default-response dialog id))
 823     widget))
 824
 825
 826 (defbinding %dialog-set-default-response () nil
 827   (dialog dialog)
 828   (response-id int))
 829
 830 (defun dialog-set-default-response (dialog response)
 831   (%dialog-set-default-response
 832    dialog (dialog-response-id dialog response nil t)))
 833
 834 (defbinding dialog-set-response-sensitive (dialog response sensitive) nil
 835   (dialog dialog)
 836   ((dialog-response-id dialog response nil t) int)
 837   (sensitive boolean))
 838
 839 #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0")
 840 (defbinding alternative-dialog-button-order-p (&optional screen) boolean
 841   (screen (or null gdk:screen)))
 842
 843 #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0")
 844 (defbinding (dialog-set-alternative-button-order
 845              "gtk_dialog_set_alternative_button_order_from_array")
 846     (dialog new-order) nil
 847   (dialog dialog)
 848   ((length new-order) int)
 849   ((map 'vector #'(lambda (response)
 850                     (dialog-response-id dialog response nil t))
 851         new-order) (vector int)))
 852
 853
 854 #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.8.0")
 855 (progn
 856   (defbinding %dialog-get-response-for-widget () int
 857     (dialog dialog)
 858     (widget widget))
 859
 860   (defun dialog-get-response-for-widget (dialog widget)
 861     (dialog-find-response dialog (dialog-get-response-for-widget dialog widget))))
 862
 863
 864 (defmethod container-add ((dialog dialog) (child widget) &rest args)
 865   (apply #'container-add (dialog-vbox dialog) child args))
 866
 867
 868 (defmethod container-remove ((dialog dialog) (child widget))
 869   (container-remove (dialog-vbox dialog) child))
 870
 871 (defmethod container-children ((dialog dialog))
 872   (container-children (dialog-vbox dialog)))
 873
 874 (defmethod (setf container-children) (children (dialog dialog))
 875   (setf (container-children (dialog-vbox dialog)) children))
 876
 877
 878 ;;; Drawing Area
 879
 880 (defun drawing-area-scroll (drawing-area dx dy)
 881   (gdk:window-scroll (widget-window drawing-area) dx dy))
 882
 883
 884 ;;; Entry
 885
 886 (defbinding entry-get-layout-offsets () nil
 887   (entry entry)
 888   (x int :out)
 889   (y int :out))
 890
 891 (defbinding entry-layout-index-to-text-index () int
 892   (entry entry)
 893   (layout-index int))
 894
 895 (defbinding entry-text-index-to-layout-index () int
 896   (entry entry)
 897   (text-index int))
 898
 899
 900 ;;; Entry Completion
 901
 902 (define-callback-marshal %entry-completion-match-callback boolean
 903   (entry-completion string tree-iter))
 904
 905 (defbinding entry-completion-set-match-func (completion function) nil
 906   (completion entry-completion)
 907   (%entry-completion-match-callback callback)
 908   ((register-callback-function function) unsigned-int)
 909   (user-data-destroy-callback callback))
 910
 911 (defbinding entry-completion-complete () nil
 912   (completion entry-completion))
 913
 914 #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0")
 915 (defbinding entry-completion-insert-prefix () nil
 916   (completion entry-completion))
 917
 918 (defbinding entry-completion-insert-action-text () nil
 919   (completion entry-completion)
 920   (index int)
 921   (text string))
 922
 923 (defbinding entry-completion-insert-action-markup () nil
 924   (completion entry-completion)
 925   (index int)
 926   (markup string))
 927
 928 (defbinding entry-completion-delete-action () nil
 929   (completion entry-completion)
 930   (index int))
 931
 932
 933 ;;; File Chooser
 934
 935 (defmethod initialize-instance ((file-chooser file-chooser) &rest initargs
 936                                 &key filter filters shortcut-folder
 937                                 shortcut-folders shortcut-folder-uti
 938                                 shortcut-folder-uris)
 939   (declare (ignore filter filters shortcut-folder shortcut-folders
 940                    shortcut-folder-uti shortcut-folder-uris))
 941   (prog1
 942       (call-next-method)
 943     (initial-add file-chooser #'file-chooser-add-filter
 944      initargs :filer :filters)
 945     (initial-add file-chooser #'file-chooser-add-shortcut-folder
 946      initargs :shortcut-folder :shortcut-folders)
 947     (initial-add file-chooser #'file-chooser-add-shortcut-folder-uri
 948      initargs :shortcut-folder-uri :shortcut-folders-uris)))
 949
 950
 951 (defbinding file-chooser-select-filename () boolean
 952   (file-chooser file-chooser)
 953   (filename string))
 954
 955 (defbinding file-chooser-unselect-filename () nil
 956   (file-chooser file-chooser)
 957   (filename string))
 958
 959 (defbinding file-chooser-select-all () boolean
 960   (file-chooser file-chooser))
 961
 962 (defbinding file-chooser-unselect-all () boolean
 963   (file-chooser file-chooser))
 964
 965 (defbinding file-chooser-get-filenames () (gslist string)
 966   (file-chooser file-chooser))
 967
 968 (defbinding file-chooser-select-uri () boolean
 969   (file-chooser file-chooser)
 970   (uri string))
 971
 972 (defbinding file-chooser-unselect-uri () nil
 973   (file-chooser file-chooser)
 974   (uri string))
 975
 976 (defbinding file-chooser-get-uris () (gslist string)
 977   (file-chooser file-chooser))
 978
 979 (defbinding file-chooser-add-filter () nil
 980   (file-chooser file-chooser)
 981   (filter file-filter))
 982
 983 (defbinding file-chooser-remove-filter () nil
 984   (file-chooser file-chooser)
 985   (filter file-filter))
 986
 987 (defbinding file-chooser-list-filters () (gslist file-filter)
 988   (file-chooser file-chooser))
 989
 990 (defbinding file-chooser-add-shortcut-folder () boolean
 991   (file-chooser file-chooser)
 992   (folder string)
 993   (nil null))
 994
 995 (defbinding file-chooser-remove-shortcut-folder () nil
 996   (file-chooser file-chooser)
 997   (folder string)
 998   (nil null))
 999
1000 (defbinding file-chooser-list-shortcut-folders () (gslist string)
1001   (file-chooser file-chooser))
1002
1003 (defbinding file-chooser-add-shortcut-folder-uri () boolean
1004   (file-chooser file-chooser)
1005   (uri string)
1006   (nil null))
1007
1008 (defbinding file-chooser-remove-shortcut-folder-uri () nil
1009   (file-chooser file-chooser)
1010   (uri string)
1011   (nil null))
1012
1013 (defbinding file-chooser-list-shortcut-folder-uris () (gslist string)
1014   (file-chooser file-chooser))
1015
1016
1017 ;;; File Filter
1018
1019 (defmethod initialize-instance ((file-filter file-filter) &rest initargs
1020                                 &key mime-type mime-types pattern patterns
1021                                 pixbuf-formats)
1022   (declare (ignore mime-type mime-types pattern patterns))
1023   (prog1
1024       (call-next-method)
1025     (when pixbuf-formats
1026       #?-(pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0")
1027       (warn "Initarg :PIXBUF-FORMATS not supportet in this version of Gtk")
1028       #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0")
1029       (file-filter-add-pixbuf-formats file-filter))
1030     (initial-add file-filter #'file-filter-add-mime-type
1031      initargs :mime-type :mime-types)
1032     (initial-add file-filter #'file-filter-add-pattern
1033      initargs :pattern :patterns)))
1034
1035
1036 (defbinding file-filter-add-mime-type () nil
1037   (filter file-filter)
1038   (mime-type string))
1039
1040 (defbinding file-filter-add-pattern () nil
1041   (filter file-filter)
1042   (pattern string))
1043
1044 #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0")
1045 (defbinding file-filter-add-pixbuf-formats () nil
1046   (filter file-filter))
1047
1048 (define-callback-marshal %file-filter-callback boolean (file-filter-info))
1049
1050 (defbinding file-filter-add-custom (filter needed function) nil
1051   (filter file-filter)
1052   (needed file-filter-flags)
1053   (%file-filter-callback callback)
1054   ((register-callback-function function) unsigned-int)
1055   (user-data-destroy-callback callback))
1056
1057 (defbinding file-filter-get-needed () file-filter-flags
1058   (filter file-filter))
1059
1060 (defbinding file-filter-filter () boolean
1061   (filter file-filter)
1062   (filter-info file-filter-info))
1063
1064
1065
1066 ;;; Image
1067
1068 (defbinding image-set-from-file () nil
1069   (image image)
1070   (filename pathname))
1071
1072 (defmethod (setf image-pixmap) ((data vector) (image image))
1073   (multiple-value-bind (pixmap mask) (gdk:pixmap-create data)
1074     (setf (image-pixmap image) pixmap)
1075     (setf (image-mask image) mask)))
1076
1077 (defmethod initialize-instance ((image image) &rest initargs &key pixmap file)
1078   (cond
1079    ((typep pixmap 'vector)
1080     (multiple-value-bind (pixmap mask) (gdk:pixmap-create pixmap)
1081       (apply #'call-next-method image :pixmap pixmap :mask mask initargs)))
1082    (file
1083     (prog1
1084         (call-next-method)
1085       (image-set-from-file image file)))
1086    ((call-next-method))))
1087
1088 (defun create-image-widget (source &optional mask)
1089   (etypecase source
1090     (gdk:pixbuf (make-instance 'image :pixbuf source))
1091     (string (make-instance 'image :stock source))
1092     (pathname (make-instance 'image :file source))
1093     ((or list vector) (make-instance 'image :pixmap source))
1094     (gdk:pixmap (make-instance 'image :pixmap source :mask mask))))
1095
1096 #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.8.0")
1097 (defbinding image-clear () nil
1098   (image image))
1099
1100
1101
1102 ;;; Image menu item
1103
1104 (defmethod initialize-instance ((item image-menu-item) &rest initargs &key image)
1105   (if (and image (not (typep image 'widget)))
1106       (apply #'call-next-method item :image (create-image-widget image) initargs)
1107     (call-next-method)))
1108
1109
1110 (defmethod (setf image-menu-item-image) ((widget widget) (item image-menu-item))
1111   (setf (slot-value item 'image) widget))
1112
1113 (defmethod (setf image-menu-item-image) (image (item image-menu-item))
1114   (setf (image-menu-item-image item) (create-image-widget image)))
1115
1116
1117 ;;; Label
1118
1119 (defmethod shared-initialize ((label label) names &key pattern)
1120   (declare (ignore names))
1121   (call-next-method)
1122   (when pattern
1123     (setf (label-pattern label) pattern)))
1124
1125 (defbinding label-get-layout-offsets () nil
1126   (label label)
1127   (x int :out)
1128   (y int :out))
1129
1130 (defbinding label-select-region () nil
1131   (label label)
1132   (start int)
1133   (end int))
1134
1135 (defbinding label-get-selection-bounds () boolean
1136   (label label)
1137   (start int :out)
1138   (end int :out))
1139
1140
1141
1142 ;;; Radio button
1143
1144 (defbinding %radio-button-get-group () pointer
1145   (radio-button radio-button))
1146
1147 (defbinding %radio-button-set-group () nil
1148   (radio-button radio-button)
1149   (group pointer))
1150
1151 (defmethod add-to-radio-group ((button1 radio-button) (button2 radio-button))
1152   "Add BUTTON1 to the group which BUTTON2 belongs to."
1153   (%radio-button-set-group button1 (%radio-button-get-group button2)))
1154
1155 (defun %add-activate-callback (widget signal function object after)
1156   (if object
1157       (signal-connect widget signal
1158        #'(lambda (object)
1159            (when (slot-value widget 'active)
1160              (funcall function object (slot-value widget 'value))))
1161        :object object :after after)
1162     (signal-connect widget signal
1163      #'(lambda ()
1164          (when (slot-value widget 'active)
1165            (funcall function (slot-value widget 'value))))
1166      :after after)))
1167
1168 (defmethod activate-radio-widget ((button radio-button))
1169   (signal-emit button 'clicked))
1170
1171 (defgeneric add-activate-callback (action function &key object after))
1172
1173 (defmethod add-activate-callback ((button radio-button) function &key object after)
1174   (%add-activate-callback button 'clicked function object after))
1175
1176 (defmethod initialize-instance ((button radio-button) &key group)
1177   (prog1
1178       (call-next-method)
1179     (when group
1180       (add-to-radio-group button group))))
1181
1182
1183 ;;; Item
1184
1185 (defbinding item-select () nil
1186   (item item))
1187
1188 (defbinding item-deselect () nil
1189   (item item))
1190
1191 (defbinding item-toggle () nil
1192   (item item))
1193
1194
1195
1196 ;;; Menu item
1197
1198 (defmethod initialize-instance ((item menu-item) &key label)
1199   (prog1
1200       (call-next-method)
1201     (when label
1202       (setf (menu-item-label item) label))))
1203
1204
1205 (defun (setf menu-item-label) (label menu-item)
1206   (make-instance 'accel-label
1207    :label label :xalign 0.0 :yalign 0.5 :accel-widget menu-item
1208    :use-underline (menu-item-use-underline-p menu-item)
1209    :visible t  :parent menu-item)
1210   label)
1211
1212 (defun menu-item-label (menu-item)
1213   (when (and (slot-boundp menu-item 'child)
1214              (typep (bin-child menu-item) 'label))
1215     (label-label (bin-child menu-item))))
1216
1217 (defbinding menu-item-remove-submenu () nil
1218   (menu-item menu-item))
1219
1220 (defbinding menu-item-set-accel-path () nil
1221   (menu-item menu-item)
1222   (accel-path string))
1223
1224 (defbinding menu-item-select () nil
1225   (menu-item menu-item))
1226
1227 (defbinding menu-item-deselect () nil
1228   (menu-item menu-item))
1229
1230 (defbinding menu-item-activate () nil
1231   (menu-item menu-item))
1232
1233 (defbinding menu-item-toggle-size-request () nil
1234   (menu-item menu-item)
1235   (requisition int :out))
1236
1237 (defbinding menu-item-toggle-size-allocate () nil
1238   (menu-item menu-item)
1239   (allocation int))
1240
1241
1242 ;;; Menu tool button
1243
1244 #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0")
1245 (defbinding menu-tool-button-set-arrow-tooltip () nil
1246   (menu-tool-button menu-tool-button)
1247   (tooltips tooltips)
1248   (tip-text string)
1249   (tip-private string))
1250
1251
1252 ;;; Message dialog
1253
1254 (defmethod allocate-foreign ((dialog message-dialog) &key (message-type :info)
1255                              (buttons :close) flags transient-parent)
1256   (%message-dialog-new transient-parent flags message-type buttons))
1257
1258
1259 (defmethod shared-initialize ((dialog message-dialog) names &key text
1260                               #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0")
1261                               secondary-text)
1262   (declare (ignore names))
1263   (when text
1264     (message-dialog-set-markup dialog text))
1265   #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0")
1266   (when secondary-text
1267     (message-dialog-format-secondary-markup dialog secondary-text))
1268   (call-next-method))
1269
1270
1271 (defbinding %message-dialog-new () pointer
1272   (parent (or null window))
1273   (flags dialog-flags)
1274   (type message-type)
1275   (buttons buttons-type)
1276   (nil null))
1277
1278 (defbinding message-dialog-set-markup () nil
1279   (message-dialog message-dialog)
1280   (markup string))
1281
1282 #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0")
1283 (defbinding message-dialog-format-secondary-text () nil
1284   (message-dialog message-dialog)
1285   (text string))
1286
1287 #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0")
1288 (defbinding message-dialog-format-secondary-markup () nil
1289   (message-dialog message-dialog)
1290   (markup string))
1291
1292
1293
1294 ;;; Radio menu item
1295
1296 (defbinding %radio-menu-item-get-group () pointer
1297   (radio-menu-item radio-menu-item))
1298
1299 (defbinding %radio-menu-item-set-group () nil
1300   (radio-menu-item radio-menu-item)
1301   (group pointer))
1302
1303 (defmethod activate-radio-widget ((item radio-menu-item))
1304   (menu-item-activate item))
1305
1306 (defmethod add-to-radio-group ((item1 radio-menu-item) (item2 radio-menu-item))
1307   "Add ITEM1 to the group which ITEM2 belongs to."
1308   (%radio-menu-item-set-group item1 (%radio-menu-item-get-group item2)))
1309
1310 (defmethod add-activate-callback ((item radio-menu-item) function &key object after)
1311   (%add-activate-callback item 'activate function object after))
1312
1313 (defmethod initialize-instance ((item radio-menu-item) &key group)
1314   (prog1
1315       (call-next-method)
1316     (when group
1317       (add-to-radio-group item group))))
1318
1319
1320
1321 ;;; Radio tool button
1322
1323 (defbinding %radio-tool-button-get-group () pointer
1324   (radio-tool-button radio-tool-button))
1325
1326 (defbinding %radio-tool-button-set-group () nil
1327   (radio-tool-button radio-tool-button)
1328   (group pointer))
1329
1330 (defmethod activate-radio-widget ((button radio-tool-button))
1331   (signal-emit button 'clicked))
1332
1333 (defmethod add-to-radio-group ((button1 radio-tool-button) (button2 radio-tool-button))
1334   "Add BUTTON1 to the group which BUTTON2 belongs to."
1335   (%radio-tool-button-set-group button1 (%radio-tool-button-get-group button2)))
1336 (defmethod add-activate-callback ((button radio-tool-button) function &key object after)
1337   (%add-activate-callback button 'clicked function object after))
1338
1339 (defmethod initialize-instance ((button radio-tool-button) &key group)
1340   (prog1
1341       (call-next-method)
1342     (when group
1343       (add-to-radio-group button group))))
1344
1345
1346
1347 ;;; Toggle button
1348
1349 (defbinding toggle-button-toggled () nil
1350   (toggle-button toggle-button))
1351
1352
1353 ;;; Window
1354
1355 (defmethod initialize-instance ((window window) &rest initargs
1356                                 &key display accel-group accel-groups)
1357   (declare (ignore accel-group accel-groups))
1358   (prog1
1359       (if display
1360           (apply #'call-next-method
1361            window :screen (gdk:display-get-default-screen display) initargs)
1362         (call-next-method))
1363     (initial-add window #'window-add-accel-group
1364      initargs :accel-group :accel-groups)))
1365
1366 #-debug-ref-counting
1367 (defmethod print-object ((window window) stream)
1368   (if (and
1369        (proxy-valid-p window)
1370        (slot-boundp window 'title)
1371        (not (zerop (length (window-title window)))))
1372       (print-unreadable-object (window stream :type t :identity nil)
1373         (format stream "~S at 0x~X"
1374          (window-title window) (pointer-address (foreign-location window))))
1375     (call-next-method)))
1376
1377 (defbinding window-set-wmclass () nil
1378   (window window)
1379   (wmclass-name string)
1380   (wmclass-class string))
1381
1382 (defbinding window-add-accel-group () nil
1383   (window window)
1384   (accel-group accel-group))
1385
1386 (defbinding window-remove-accel-group () nil
1387   (window window)
1388   (accel-group accel-group))
1389
1390 (defbinding window-activate-focus () int
1391   (window window))
1392
1393 (defbinding window-activate-default () int
1394   (window window))
1395
1396 (defbinding window-set-default-size (window width height) int
1397   (window window)
1398   ((or width -1) int)
1399   ((or height -1) int))
1400
1401 (defbinding %window-set-geometry-hints () nil
1402   (window window)
1403   (geometry gdk:geometry)
1404   (geometry-mask gdk:window-hints))
1405
1406 (defun window-set-geometry-hints (window &key min-width min-height
1407                                   max-width max-height base-width base-height
1408                                   width-inc height-inc min-aspect max-aspect
1409                                   (gravity nil gravity-p) min-size max-size)
1410   (let ((geometry (make-instance 'gdk:geometry
1411                    :min-width (or min-width -1)
1412                    :min-height (or min-height -1)
1413                    :max-width (or max-width -1)
1414                    :max-height (or max-height -1)
1415                    :base-width (or base-width 0)
1416                    :base-height (or base-height 0)
1417                    :width-inc (or width-inc 0)
1418                    :height-inc (or height-inc 0)
1419                    :min-aspect (or min-aspect 0)
1420                    :max-aspect (or max-aspect 0)
1421                    :gravity gravity))
1422         (mask ()))
1423     (when (or min-size min-width min-height)
1424       (push :min-size mask))
1425     (when (or max-size max-width max-height)
1426       (push :max-size mask))
1427     (when (or base-width base-height)
1428       (push :base-size mask))
1429     (when (or width-inc height-inc)
1430       (push :resize-inc mask))
1431     (when (or min-aspect max-aspect)
1432       (push :aspect mask))
1433     (when gravity-p
1434       (push :win-gravity mask))
1435     (%window-set-geometry-hints window geometry mask)))
1436
1437 (defbinding window-list-toplevels () (glist (copy-of window))
1438   "Returns a list of all existing toplevel windows.")
1439
1440 (defbinding window-add-mnemonic (window key target) nil
1441   (window window)
1442   ((gdk:keyval-from-name key) unsigned-int)
1443   (target widget))
1444
1445 (defbinding window-remove-mnemonic (window key target) nil
1446   (window window)
1447   ((gdk:keyval-from-name key) unsigned-int)
1448   (target widget))
1449
1450 (defbinding window-mnemonic-activate (window key modifier) nil
1451   (window window)
1452   ((gdk:keyval-from-name key) unsigned-int)
1453   (modifier gdk:modifier-type))
1454
1455 (defbinding window-activate-key () boolean
1456   (window window)
1457   (event gdk:key-event))
1458
1459 (defbinding window-propagate-key-event () boolean
1460   (window window)
1461   (event gdk:key-event))
1462
1463 #?-(pkg-exists-p "gtk+-2.0" :atleast-version "2.8.0")
1464 (defbinding window-present () nil
1465   (window window))
1466
1467 #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.8.0")
1468 (progn
1469   (defbinding %window-present () nil
1470     (window window))
1471
1472   (defbinding %window-present-with-time () nil
1473     (window window)
1474     (timespamp unsigned-int))
1475
1476   (defun window-present (window &optional timestamp)
1477     (if timestamp
1478         (%window-present-with-time window timestamp)
1479       (%window-present window))))
1480
1481 (defbinding window-iconify () nil
1482   (window window))
1483
1484 (defbinding window-deiconify () nil
1485   (window window))
1486
1487 (defbinding window-stick () nil
1488   (window window))
1489
1490 (defbinding window-unstick () nil
1491   (window window))
1492
1493 (defbinding window-maximize () nil
1494   (window window))
1495
1496 (defbinding window-unmaximize () nil
1497   (window window))
1498
1499 (defbinding window-fullscreen () nil
1500   (window window))
1501
1502 (defbinding window-unfullscreen () nil
1503   (window window))
1504
1505 (defbinding window-set-keep-above () nil
1506   (window window)
1507   (setting boolean))
1508
1509 (defbinding window-set-keep-below () nil
1510   (window window)
1511   (setting boolean))
1512
1513 (defbinding window-begin-resize-drag () nil
1514   (window window)
1515   (edge gdk:window-edge)
1516   (button int)
1517   (root-x int) (root-y int)
1518   (timestamp unsigned-int))
1519
1520 (defbinding window-begin-move-drag () nil
1521   (window window)
1522   (edge gdk:window-edge)
1523   (button int)
1524   (root-x int) (root-y int)
1525   (timestamp unsigned-int))
1526
1527 (defbinding window-set-frame-dimensions () nil
1528   (window window)
1529   (left int) (top int) (rigth int) (bottom int))
1530
1531 (defbinding %window-get-default-size () nil
1532   (window window)
1533   (width int :out)
1534   (height int :out))
1535
1536 (defun window-get-default-size (window)
1537   (multiple-value-bind (width height) (%window-get-default-size window)
1538     (values (unless (= width -1) width) (unless (= height -1) height))))
1539
1540 (defbinding window-get-frame-dimensions () nil
1541   (window window)
1542   (left int :out) (top int :out) (rigth int :out) (bottom int :out))
1543
1544 (defbinding %window-get-icon-list () (glist (copy-of gdk:pixbuf))
1545   (window window))
1546
1547 (defbinding window-get-position () nil
1548   (window window)
1549   (root-x int :out)
1550   (root-y int :out))
1551
1552 (defbinding window-get-size () nil
1553   (window window)
1554   (width int :out)
1555   (height int :out))
1556
1557 (defbinding window-move () nil
1558   (window window)
1559   (x int)
1560   (y int))
1561
1562 (defbinding window-parse-geometry () boolean
1563   (window window)
1564   (geometry string))
1565
1566 (defbinding window-reshow-with-initial-size () nil
1567   (window window))
1568
1569 (defbinding window-resize () nil
1570   (window window)
1571   (width int)
1572   (heigth int))
1573
1574 (defbinding (window-default-icon-list "gtk_window_get_default_icon_list")
1575     () (glist gdk:pixbuf))
1576
1577 (defun window-default-icon ()
1578   (first (window-default-icon-list)))
1579
1580 (defbinding %window-set-default-icon-list () nil
1581   (icons (glist gdk:pixbuf)))
1582
1583 (defun (setf window-default-icon-list) (icons)
1584   (%window-set-default-icon-list icons)
1585   icons)
1586
1587 (defbinding %window-set-default-icon () nil
1588   (icons (glist gdk:pixbuf)))
1589
1590 (defgeneric (setf window-default-icon) (icon))
1591
1592 (defmethod (setf window-default-icon) ((icon gdk:pixbuf))
1593   (%window-set-default-icon icon)
1594   icon)
1595
1596 (defgeneric (setf window-group) (group window))
1597
1598 (defmethod (setf window-group) ((group window-group) (window window))
1599   (window-group-add-window group window)
1600   group)
1601
1602 (defbinding %window-set-default-icon-from-file () boolean
1603   (filename pathname)
1604   (nil null))
1605
1606 (defmethod (setf window-default-icon) ((icon-file pathname))
1607   (%window-set-default-icon-from-file icon-file)
1608   icon-file)
1609
1610 (defbinding %window-set-icon-from-file () boolean
1611   (window window)
1612   (filename pathname)
1613   (nil null))
1614
1615 (defmethod (setf window-icon) ((icon-file pathname) (window window))
1616   (%window-set-icon-from-file window icon-file)
1617   icon-file)
1618
1619 (defbinding window-set-auto-startup-notification () nil
1620   (setting boolean))
1621
1622 (defbinding decorated-window-init () nil
1623   (window window))
1624
1625 (defbinding decorated-window-calculate-frame-size () nil
1626   (window window))
1627
1628 (defbinding decorated-window-set-title () nil
1629   (window window)
1630   (title string))
1631
1632 (defbinding decorated-window-move-resize-window () nil
1633   (window window)
1634   (x int)
1635   (y int)
1636   (width int)
1637   (heigth int))
1638
1639
1640 ;;; Window group
1641
1642 (defmethod initialize-instance ((window-group window-group) &rest initargs
1643                                 &key window windows)
1644   (declare (ignore window windows))
1645   (prog1
1646       (call-next-method)
1647     (initial-add window-group #'window-group-add-window
1648      initargs :window :windows)))
1649
1650
1651 (defbinding window-group-add-window () nil
1652   (window-group window-group)
1653   (window window))
1654
1655 (defbinding window-group-remove-window () nil
1656   (window-group window-group)
1657   (window window))
1658
1659
1660 ;;; Scrolled window
1661
1662 (defun (setf scrolled-window-scrollbar-policy) (policy window)
1663   (setf (scrolled-window-hscrollbar-policy window) policy)
1664   (setf (scrolled-window-vscrollbar-policy window) policy))
1665
1666 (defbinding scrolled-window-add-with-viewport () nil
1667    (scrolled-window scrolled-window)
1668    (child widget))
1669
1670 (defmethod shared-initialize ((window scrolled-window) names &key policy)
1671   (declare (ignore names))
1672   (when policy
1673     (setf (slot-value window 'hscrollbar-policy) policy)
1674     (setf (slot-value window 'vscrollbar-policy) policy))
1675   (call-next-method))
1676
1677
1678 ;;; Statusbar
1679
1680 (defbinding statusbar-get-context-id () unsigned-int
1681   (statusbar statusbar)
1682   (context-description string))
1683
1684 (defbinding statusbar-push () unsigned-int
1685   (statusbar statusbar)
1686   (context-id unsigned-int)
1687   (text string))
1688
1689 (defbinding statusbar-pop () nil
1690   (statusbar statusbar)
1691   (context-id unsigned-int))
1692
1693 (defbinding statusbar-remove () nil
1694   (statusbar statusbar)
1695   (context-id unsigned-int)
1696   (message-id unsigned-int))
1697
1698
1699
1700 ;;; Fixed
1701
1702 (defbinding fixed-put () nil
1703   (fixed fixed)
1704   (widget widget)
1705   (x int) (y int))
1706
1707 (defbinding fixed-move () nil
1708   (fixed fixed)
1709   (widget widget)
1710   (x int) (y int))
1711
1712
1713
1714 ;;; Notebook
1715
1716 (defun %ensure-notebook-position (notebook page)
1717   (etypecase page
1718     (position page)
1719     (widget (notebook-page-num notebook page t))))
1720
1721 (defun %ensure-notebook-child (notebook position)
1722   (typecase position
1723      (widget position)
1724      (t (notebook-get-nth-page notebook position))))
1725
1726 (defbinding (notebook-insert "gtk_notebook_insert_page_menu")
1727     (notebook position child &optional tab-label menu-label) nil
1728   (notebook notebook)
1729   (child widget)
1730   ((if (stringp tab-label)
1731        (make-instance 'label :label tab-label)
1732      tab-label) (or null widget))
1733   ((if (stringp menu-label)
1734        (make-instance 'label :label menu-label)
1735      menu-label) (or null widget))
1736   ((%ensure-notebook-position notebook position) position))
1737
1738 (defun notebook-append (notebook child &optional tab-label menu-label)
1739   (notebook-insert notebook :last child tab-label menu-label))
1740
1741 (defun notebook-prepend (notebook child &optional tab-label menu-label)
1742   (notebook-insert notebook :first child tab-label menu-label))
1743
1744 (defbinding notebook-remove-page (notebook page) nil
1745   (notebook notebook)
1746   ((%ensure-notebook-position notebook page) position))
1747
1748 (defbinding %notebook-page-num () int
1749   (notebook notebook)
1750   (child widget))
1751
1752 (defun notebook-page-num (notebook child &optional error-p)
1753   (let ((page-num (%notebook-page-num notebook child)))
1754     (if (= page-num -1)
1755         (when error-p
1756           (error "~A is not a page in ~A" child notebook))
1757       page-num)))
1758
1759 (defbinding notebook-next-page () nil
1760   (notebook notebook))
1761
1762 (defbinding notebook-prev-page () nil
1763   (notebook notebook))
1764
1765 (defbinding notebook-reorder-child (notebook child position) nil
1766   (notebook notebook)
1767   (child widget)
1768   ((%ensure-notebook-position notebook position) int))
1769
1770 (defbinding notebook-popup-enable () nil
1771   (notebook notebook))
1772
1773 (defbinding notebook-popup-disable () nil
1774   (notebook notebook))
1775
1776 (defbinding notebook-get-nth-page () widget
1777   (notebook notebook)
1778   (page position))
1779
1780 (defun %notebook-current-page (notebook)
1781   (when (slot-boundp notebook 'current-page-num)
1782     (notebook-get-nth-page notebook (notebook-current-page-num notebook))))
1783
1784 (defun (setf notebook-current-page) (page notebook)
1785   (setf (notebook-current-page-num notebook) (notebook-page-num notebook page)))
1786
1787 (defbinding (notebook-tab-label "gtk_notebook_get_tab_label")
1788     (notebook page) widget
1789   (notebook notebook)
1790   ((%ensure-notebook-child notebook page) widget))
1791
1792 (defbinding (notebook-tab-label-text "gtk_notebook_get_tab_label_text")
1793     (notebook page) (copy-of string)
1794   (notebook notebook)
1795   ((%ensure-notebook-child notebook page) widget))
1796
1797 (defbinding %notebook-set-tab-label () nil
1798   (notebook notebook)
1799   (page widget)
1800   (tab-label widget))
1801
1802 (defun (setf notebook-tab-label) (tab-label notebook page)
1803   (let ((widget (if (stringp tab-label)
1804                     (make-instance 'label :label tab-label)
1805                   tab-label)))
1806     (%notebook-set-tab-label notebook (%ensure-notebook-child notebook page) widget)
1807     widget))
1808
1809
1810 (defbinding (notebook-menu-label "gtk_notebook_get_menu_label")
1811     (notebook page) widget
1812   (notebook notebook)
1813   ((%ensure-notebook-child notebook page) widget))
1814
1815 (defbinding (notebook-menu-label-text "gtk_notebook_get_menu_label_text")
1816     (notebook page) (copy-of string)
1817   (notebook notebook)
1818   ((%ensure-notebook-child notebook page) widget))
1819
1820 (defbinding %notebook-set-menu-label () nil
1821   (notebook notebook)
1822   (page widget)
1823   (menu-label widget))
1824
1825 (defun (setf notebook-menu-label) (menu-label notebook page)
1826   (let ((widget (if (stringp menu-label)
1827                     (make-instance 'label :label menu-label)
1828                   menu-label)))
1829     (%notebook-set-menu-label notebook (%ensure-notebook-child notebook page) widget)
1830     widget))
1831
1832
1833 (defbinding notebook-query-tab-label-packing (notebook page) nil
1834   (notebook notebook)
1835   ((%ensure-notebook-child notebook page) widget)
1836   (expand boolean :out)
1837   (fill boolean :out)
1838   (pack-type pack-type :out))
1839
1840 (defbinding notebook-set-tab-label-packing
1841     (notebook page expand fill pack-type) nil
1842   (notebook notebook)
1843   ((%ensure-notebook-child notebook page) widget)
1844   (expand boolean)
1845   (fill boolean)
1846   (pack-type pack-type))
1847
1848
1849
1850 ;;; Paned
1851
1852 (defbinding paned-pack1 () nil
1853   (paned paned)
1854   (child widget)
1855   (resize boolean)
1856   (shrink boolean))
1857
1858 (defbinding paned-pack2 () nil
1859   (paned paned)
1860   (child widget)
1861   (resize boolean)
1862   (shrink boolean))
1863
1864
1865 ;;; Layout
1866
1867 (defbinding layout-put () nil
1868   (layout layout)
1869   (child widget)
1870   (x int)
1871   (y int))
1872
1873 (defbinding layout-move () nil
1874   (layout layout)
1875   (child widget)
1876   (x int)
1877   (y int))
1878
1879 (defbinding layout-set-size () nil
1880   (layout layout)
1881   (width unsigned-int)
1882   (height unsigned-int))
1883
1884 (defbinding layout-get-size () nil
1885   (layout layout)
1886   (width unsigned-int :out)
1887   (height unsigned-int :out))
1888
1889
1890 ;;; Menu shell
1891
1892 (defbinding menu-shell-insert (menu-shell menu-item position) nil
1893   (menu-shell menu-shell)
1894   (menu-item menu-item)
1895   ((case position
1896      (:first 0)
1897      (:last -1)
1898      (t position)) int))
1899
1900 (defun menu-shell-append (menu-shell menu-item)
1901   (menu-shell-insert menu-shell menu-item :last))
1902
1903 (defun menu-shell-prepend (menu-shell menu-item)
1904   (menu-shell-insert menu-shell menu-item :fisrt))
1905
1906 (defbinding menu-shell-deactivate () nil
1907   (menu-shell menu-shell))
1908
1909 (defbinding menu-shell-select-item () nil
1910   (menu-shell menu-shell)
1911   (menu-item menu-item))
1912
1913 (defbinding menu-shell-select-first () nil
1914   (menu-shell menu-shell)
1915   (search-sensitive boolean))
1916
1917 (defbinding menu-shell-deselect () nil
1918   (menu-shell menu-shell))
1919
1920 (defbinding menu-shell-activate-item () nil
1921   (menu-shell menu-shell)
1922   (menu-item menu-item)
1923   (fore-deactivate boolean))
1924
1925 (defbinding menu-shell-cancel () nil
1926   (menu-shell menu-shell))
1927
1928
1929 ;;; Menu
1930
1931 (defun %menu-position (menu child)
1932   (etypecase child
1933     (int child)
1934     (keyword (case child
1935                (:first 0)
1936                (:last -1)
1937                (t (error "Invalid position keyword: ~A" child))))
1938     (widget (menu-child-position menu child))))
1939
1940
1941 (defbinding menu-reorder-child (menu menu-item position) nil
1942   (menu menu)
1943   (menu-item menu-item)
1944   ((%menu-position menu position) int))
1945
1946 (defbinding menu-attach () nil
1947   (menu menu)
1948   (menu-item menu-item)
1949   (left-attach unsigned-int)
1950   (right-attach unsigned-int)
1951   (top-attach unsigned-int)
1952   (bottom-attach unsigned-int))
1953
1954 (define-callback-marshal %menu-position-callback nil
1955   (menu (x int) (y int) (push-in boolean)))
1956
1957 (defbinding %menu-popup () nil
1958   (menu menu)
1959   (parent-menu-shell (or null menu-shell))
1960   (parent-menu-item (or null menu-item))
1961   (callback (or null callback))
1962   (callback-id unsigned-int)
1963   (button unsigned-int)
1964   (activate-time (unsigned 32)))
1965
1966 (defun menu-popup (menu button activate-time &key callback parent-menu-shell
1967                    parent-menu-item)
1968   (if callback
1969       (with-callback-function (id callback)
1970         (%menu-popup
1971          menu parent-menu-shell parent-menu-item
1972          %menu-position-callback id button activate-time))
1973     (%menu-popup
1974      menu parent-menu-shell parent-menu-item nil 0 button activate-time)))
1975
1976 (defbinding menu-set-accel-path () nil
1977   (menu menu)
1978   (accel-path string))
1979
1980 (defbinding menu-reposition () nil
1981   (menu menu))
1982
1983 (defbinding menu-popdown () nil
1984   (menu menu))
1985
1986 (defun menu-child-position (menu child)
1987   (position child (container-children menu)))
1988
1989 (defun menu-active-num (menu)
1990   (menu-child-position menu (menu-active menu)))
1991
1992 (defbinding %menu-set-active () nil
1993   (menu menu)
1994   (index unsigned-int))
1995
1996 (defun (setf menu-active) (menu child)
1997   (%menu-set-active menu (%menu-position menu child))
1998   child)
1999
2000 (define-callback %menu-detach-callback nil ((widget widget) (menu menu))
2001   (funcall (user-data menu 'detach-func) widget menu))
2002
2003 (defbinding %menu-attach-to-widget (menu widget) nil
2004   (menu menu)
2005   (widget widget)
2006   (%menu-detach-callback callback))
2007
2008 (defun menu-attach-to-widget (menu widget function)
2009   (setf (user-data menu 'detach-func) function)
2010   (%menu-attach-to-widget menu widget))
2011
2012 (defbinding menu-detach () nil
2013   (menu menu))
2014
2015 #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0")
2016 (defbinding menu-get-for-attach-widget () (copy-of (glist widget))
2017   (widget widget))
2018
2019 (defbinding menu-set-monitor () nil
2020   (menu menu)
2021   (monitor-num int))
2022
2023
2024 ;;; Table
2025
2026 (defbinding table-resize () nil
2027   (table table)
2028   (rows unsigned-int)
2029   (columns unsigned-int))
2030
2031 (defbinding table-attach (table child left right top bottom
2032                           &key options x-options y-options
2033                           (x-padding 0) (y-padding 0)) nil
2034   (table table)
2035   (child widget)
2036   (left unsigned-int)
2037   (right unsigned-int)
2038   (top unsigned-int)
2039   (bottom unsigned-int)
2040   ((append (mklist options) (mklist x-options)) attach-options)
2041   ((append (mklist options) (mklist y-options)) attach-options)
2042   (x-padding unsigned-int)
2043   (y-padding unsigned-int))
2044
2045
2046 (defbinding %table-set-row-spacing () nil
2047   (table table)
2048   (row unsigned-int)
2049   (spacing unsigned-int))
2050
2051 (defbinding %table-set-row-spacings () nil
2052   (table table)
2053   (spacing unsigned-int))
2054
2055 (defun (setf table-row-spacing) (spacing table &optional row)
2056   (if row
2057       (%table-set-row-spacing table row spacing)
2058     (%table-set-row-spacings table spacing))
2059   spacing)
2060
2061 (defbinding %table-get-row-spacing () unsigned-int
2062   (table table)
2063   (row unsigned-int))
2064
2065 (defbinding %table-get-default-row-spacing () unsigned-int
2066   (table table))
2067
2068 (defun table-row-spacing (table &optional row)
2069   (if row
2070       (%table-get-row-spacing table row)
2071     (%table-get-default-row-spacing table)))
2072
2073
2074 (defbinding %table-set-col-spacing () nil
2075   (table table)
2076   (col unsigned-int)
2077   (spacing unsigned-int))
2078
2079 (defbinding %table-set-col-spacings () nil
2080   (table table)
2081   (spacing unsigned-int))
2082
2083 (defun (setf table-column-spacing) (spacing table &optional column)
2084   (if column
2085       (%table-set-col-spacing table column spacing)
2086     (%table-set-col-spacings table spacing))
2087   spacing)
2088
2089 (defun (setf table-col-spacing) (spacing table &optional col)
2090   (warn "TABLE-COL-SPACING is deprecatet, use TABLE-COLUMN-SPACING instead")
2091   (setf (table-column-spacing table col) spacing))
2092
2093 (defbinding %table-get-col-spacing () unsigned-int
2094   (table table)
2095   (col unsigned-int))
2096
2097 (defbinding %table-get-default-col-spacing () unsigned-int
2098   (table table))
2099
2100 (defun table-column-spacing (table &optional column)
2101   (if column
2102       (%table-get-col-spacing table column)
2103     (%table-get-default-col-spacing table)))
2104
2105 (defun table-col-spacing (table &optional col)
2106   (warn "TABLE-COL-SPACING is deprecatet, use TABLE-COLUMN-SPACING instead")
2107   (table-column-spacing table col))
2108
2109
2110
2111 ;;; Toolbar
2112
2113 (defmethod initialize-instance ((toolbar toolbar) &rest initargs &key tooltips)
2114   (if (eq tooltips t)
2115       (apply #'call-next-method toolbar
2116        :tooltips (make-instance 'tooltips) initargs)
2117     (call-next-method)))
2118
2119 (defbinding %toolbar-insert () nil
2120   (toolbar toolbar)
2121   (tool-item tool-item)
2122   (position position))
2123
2124 (defun toolbar-insert (toolbar tool-item &optional (position :end))
2125   (%toolbar-insert toolbar tool-item position)
2126   (%tool-item-update-tooltips tool-item))
2127
2128 (defbinding toolbar-get-item-index () int
2129   (toolbar toolbar)
2130   (item tool-item))
2131
2132 (defbinding toolbar-get-nth-item () tool-item
2133   (toolbar toolbar)
2134   (n int))
2135
2136 (defbinding toolbar-get-drop-index () int
2137   (toolbar toolbar)
2138   (x int) (y int))
2139
2140 (defbinding toolbar-set-drop-highlight-item () nil
2141   (toolbar toolbar)
2142   (tool-item tool-item)
2143   (index int))
2144
2145
2146 ;;; Tool button
2147
2148 (defmethod initialize-instance ((button tool-button) &rest initargs &key icon)
2149   (if (and icon (not (typep icon 'widget)))
2150       (apply #'call-next-method button :icon (create-image-widget icon) initargs)
2151     (call-next-method)))
2152
2153
2154 ;;; Tool item
2155
2156 (defbinding tool-item-set-tooltip () nil
2157   (tool-item tool-item)
2158   (tooltips tooltips)
2159   (tip-text string)
2160   (tip-private string))
2161
2162
2163 (defun %tool-item-update-tooltips (tool-item)
2164   (when (and
2165          (slot-boundp tool-item 'parent)
2166          (or
2167           (user-data-p tool-item 'tip-text)
2168           (user-data-p tool-item 'tip-private)))
2169     (tool-item-set-tooltip
2170      tool-item (toolbar-tooltips (widget-parent tool-item))
2171      (or (user-data tool-item 'tip-text) "")
2172      (or (user-data tool-item 'tip-private) ""))))
2173
2174 (defmethod (setf tool-item-tip-text) ((tip-text string) (tool-item tool-item))
2175   (setf (user-data tool-item 'tip-text) tip-text)
2176   (%tool-item-update-tooltips tool-item)
2177   tip-text)
2178
2179 (defmethod (setf tool-item-tip-private) ((tip-private string) (tool-item tool-item))
2180   (setf (user-data tool-item 'tip-private) tip-private)
2181   (%tool-item-update-tooltips tool-item)
2182   tip-private)
2183
2184 (defmethod container-add ((toolbar toolbar) (tool-item tool-item) &rest args)
2185   (declare (ignore args))
2186   (prog1
2187       (call-next-method)
2188     (%tool-item-update-tooltips tool-item)))
2189
2190
2191 (defbinding tool-item-retrieve-proxy-menu-item () widget
2192   (tool-item tool-item))
2193
2194 (defbinding (tool-item-proxy-menu-item
2195              "gtk_tool_item_get_proxy_menu_item") () menu-item
2196   (tool-item tool-item)
2197   (menu-item-id string))
2198
2199 (defbinding %tool-item-set-proxy-menu-item () nil
2200   (tool-item tool-item)
2201   (menu-item-id string)
2202   (menu-item menu-item))
2203
2204 (defun (setf tool-item-proxy-menu-item) (menu-item menu-item-id tool-item)
2205   (%tool-item-set-proxy-menu-item menu-item-id tool-item menu-item)
2206    menu-item)
2207
2208 #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0")
2209 (defbinding tool-item-rebuild-menu () nil
2210   (tool-item tool-item))
2211
2212
2213 ;;; Editable
2214
2215 (defbinding editable-select-region (editable &optional (start 0) end) nil
2216   (editable editable)
2217   (start int)
2218   ((or end -1) int))
2219
2220 (defbinding editable-get-selection-bounds (editable) nil
2221   (editable editable)
2222   (start int :out)
2223   (end int :out))
2224
2225 (defbinding editable-insert-text (editable text &optional (position 0)) nil
2226   (editable editable)
2227   (text string)
2228   ((length text) int)
2229   (position position :in/out))
2230
2231 (defun editable-append-text (editable text)
2232   (editable-insert-text editable text nil))
2233
2234 (defun editable-prepend-text (editable text)
2235   (editable-insert-text editable text 0))
2236
2237 (defbinding editable-delete-text (editable &optional (start 0) end) nil
2238   (editable editable)
2239   (start int)
2240   ((or end -1) int))
2241
2242 (defbinding (editable-text "gtk_editable_get_chars")
2243     (editable &optional (start 0) end) string
2244   (editable editable)
2245   (start int)
2246   ((or end -1) int))
2247
2248 (defun (setf editable-text) (text editable)
2249   (if text
2250       (editable-delete-text
2251        editable
2252        (editable-insert-text editable text))
2253     (editable-delete-text editable))
2254   text)
2255
2256 (defbinding editable-cut-clipboard () nil
2257   (editable editable))
2258
2259 (defbinding editable-copy-clipboard () nil
2260   (editable editable))
2261
2262 (defbinding editable-paste-clipboard () nil
2263   (editable editable))
2264
2265 (defbinding editable-delete-selection () nil
2266   (editable editable))
2267
2268
2269
2270 ;;; Spin button
2271
2272 (defbinding spin-button-configure () nil
2273   (spin-button spin-button)
2274   (adjustment adjustment)
2275   (climb-rate double-float)
2276   (digits unsigned-int))
2277
2278 (defbinding spin-button-set-range () nil
2279   (spin-button spin-button)
2280   (min double-float)
2281   (max double-float))
2282
2283 (defbinding spin-button-get-range () nil
2284   (spin-button spin-button)
2285   (min double-float :out)
2286   (max double-float :out))
2287
2288 (defun spin-button-value-as-int (spin-button)
2289   (round (spin-button-value spin-button)))
2290
2291 (defbinding %spin-button-spin () nil
2292   (spin-button spin-button)
2293   (direction spin-type)
2294   (increment double-float))
2295
2296 (defun spin-button-spin (spin-button value)
2297   (etypecase value
2298     (real (%spin-button-spin spin-button :spin-user-defined value))
2299     (spin-type (%spin-button-spin spin-button value 0))))
2300
2301
2302 (defbinding spin-button-update () nil
2303   (spin-button spin-button))
2304
2305
2306
2307 ; ;;; Ruler
2308
2309 (defbinding ruler-set-range () nil
2310   (ruler ruler)
2311   (lower single-float)
2312   (upper single-float)
2313   (position single-float)
2314   (max-size single-float))
2315
2316 (defbinding ruler-get-range () nil
2317   (ruler ruler)
2318   (lower single-float :out)
2319   (upper single-float :out)
2320   (position single-float :out)
2321   (max-size single-float :out))
2322
2323
2324
2325 ;;; Range
2326
2327 (defun range-lower (range)
2328   (adjustment-lower (range-adjustment range)))
2329
2330 (defun range-upper (range)
2331   (adjustment-upper (range-adjustment range)))
2332
2333 (defun (setf range-lower) (value range)
2334   (setf (adjustment-lower (range-adjustment range)) value))
2335
2336 (defun (setf range-upper) (value range)
2337   (setf (adjustment-upper (range-adjustment range)) value))
2338
2339 (defun range-page-increment (range)
2340   (adjustment-page-increment (range-adjustment range)))
2341
2342 (defun range-step-increment (range)
2343   (adjustment-step-increment (range-adjustment range)))
2344
2345 (defun (setf range-page-increment) (value range)
2346   (setf (adjustment-page-increment (range-adjustment range)) value))
2347
2348 (defun (setf range-step-increment) (value range)
2349   (setf (adjustment-step-increment (range-adjustment range)) value))
2350
2351 (defbinding range-set-range () nil
2352   (range range)
2353   (lower double-float)
2354   (upper double-float))
2355
2356 (defbinding range-set-increments () nil
2357   (range range)
2358   (step double-float)
2359   (page double-float))
2360
2361
2362 ;;; Scale
2363
2364 (defbinding scale-get-layout-offsets () nil
2365   (scale scale)
2366   (x int :out)
2367   (y int :out))
2368
2369
2370 ;;; Progress bar
2371
2372 (defbinding progress-bar-pulse () nil
2373   (progress-bar progress-bar))
2374
2375
2376 ;;; Size group
2377
2378 (defmethod initialize-instance ((size-group size-group) &rest initargs
2379                                 &key widget widgets)
2380   (declare (ignore widget widgets))
2381   (prog1
2382       (call-next-method)
2383     (initial-add size-group #'size-group-add-widget
2384      initargs :widget :widgets)))
2385
2386
2387 (defbinding size-group-add-widget () nil
2388   (size-group size-group)
2389   (widget widget))
2390
2391 (defbinding size-group-remove-widget () nil
2392   (size-group size-group)
2393   (widget widget))
2394
2395
2396 ;;; Stock items
2397
2398 (defbinding %stock-item-copy () pointer
2399   (location pointer))
2400
2401 (defbinding %stock-item-free () nil
2402   (location pointer))
2403
2404 (defbinding stock-add (stock-item) nil
2405   (stock-item stock-item)
2406   (1 unsigned-int))
2407
2408 (defbinding stock-list-ids () (gslist string))
2409
2410 (defbinding %stock-lookup () boolean
2411   (stock-id string)
2412   (location pointer))
2413
2414 (defun stock-lookup (stock-id)
2415   (with-memory (stock-item (foreign-size (find-class 'stock-item)))
2416     (when (%stock-lookup stock-id stock-item)
2417       (ensure-proxy-instance 'stock-item (%stock-item-copy stock-item)))))
2418
2419 #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.8.0")
2420 (progn
2421   (define-callback-marshal %stock-translate-callback string ((path string)))
2422
2423   (defbinding (stock-set-translate-function "gtk_stock_set_translate_func")
2424       (domain function) nil
2425     (domain string)
2426     (%stock-translate-callback callback)
2427     ((register-callback-function function) unsigned-int)
2428     (user-data-destroy-callback callback)))
2429
2430
2431
2432 ;;; Tooltips
2433
2434 (defbinding tooltips-enable () nil
2435   (tooltips tooltips))
2436
2437 (defbinding tooltips-disable () nil
2438   (tooltips tooltips))
2439
2440 (defun (setf tooltips-enabled-p) (enable tooltips)
2441   (if enable
2442       (tooltips-enable tooltips)
2443     (tooltips-disable tooltips)))
2444
2445 (defbinding tooltips-set-tip () nil
2446   (tooltips tooltips)
2447   (widget widget)
2448   (tip-text string)
2449   (tip-private string))
2450
2451 (defbinding tooltips-data-get () tooltips-data
2452   (widget widget))
2453
2454 (defbinding tooltips-force-window () nil
2455   (tooltips tooltips))
2456
2457 (defbinding tooltips-get-info-from-tip-window () boolean
2458   (tip-window window)
2459   (tooltips tooltips :out)
2460   (current-widget widget :out))
2461
2462
2463 ;;; Resource Files
2464
2465 (defbinding rc-get-style () style
2466   (widget widget))
2467
2468 (defbinding rc-get-style-by-paths (&key path class-path class) style
2469   (path (or null string))
2470   (class-path (or null string))
2471   (class gtype))
2472
2473 (defbinding rc-parse () nil
2474   (filename pathname))
2475
2476 (defbinding rc-parse-string () nil
2477   (rc-string string))
2478
2479 (defbinding %rc-reparse-all () boolean)
2480
2481 (defbinding %rc-reparse-all-for-settings () boolean
2482   (settings settings)
2483   (force-load-p boolean))
2484
2485 (defun rc-reparse-all (&optional setting force-load-p)
2486   (if setting
2487       (%rc-reparse-all-for-settings setting force-load-p)
2488     (%rc-reparse-all)))
2489
2490 (defbinding rc-reset-styles () nil
2491   (settings settings))
2492
2493 (defbinding rc-add-default-file () nil
2494   (filename pathname))
2495
2496 (defbinding rc-get-default-files ()
2497     (copy-of (null-terminated-vector (copy-of string))))
2498
2499 (defbinding rc-get-module-dir () string)
2500
2501 (defbinding rc-get-im-module-path () string)
2502
2503 (defbinding rc-get-im-module-file () string)
2504
2505 (defbinding rc-get-theme-dir () string)
2506
2507
2508 ;;; Settings
2509
2510 (defbinding (settings-get "gtk_settings_get_for_screen")
2511     (&optional (screen (gdk:display-get-default-screen))) settings
2512   (screen gdk:screen))
2513
2514
2515 ;;; Plug and Socket
2516
2517 (defbinding socket-add-id () nil
2518   (socket socket)
2519   (id gdk:native-window))
2520
2521 (defbinding %plug-new () pointer
2522   (id gdk:native-window))
2523
2524 (defmethod allocate-foreign ((plug plug) &key id)
2525   (%plug-new (or id 0)))
2526
2527
2528 ;;;; New stuff in Gtk+ 2.10
2529
2530 ;;; Link button
2531
2532 #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.10.0")
2533 (progn
2534   (define-callback-marshal %link-button-uri-callback nil (link-button (link string)))
2535
2536   (defbinding link-button-set-uri-hook (function) pointer
2537     (%link-button-uri-callback callback)
2538     ((register-callback-function function) unsigned-int)
2539     (user-data-destroy-callback callback)))