git.chise.org Git - chise/xemacs-chise.git-/blob - tests/gtk/gtk-test.el

   1 ;;; gtk-test.el --- Test harness for GTK widgets
   2
   3 ;; Copyright (C) 2000 Free Software Foundation
   4
   5 ;; Maintainer: William Perry <wmperry@gnu.org>
   6 ;; Keywords: tests
   7
   8 ;; This file is part of XEmacs.
   9
  10 ;; XEmacs is free software; you can redistribute it and/or modify it
  11 ;; under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; XEmacs is distributed in the hope that it will be useful, but
  16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  18 ;; General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  22 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
  23 ;; 02111-1307, USA.
  24
  25 ;;; Synched up with: Not in FSF
  26
  27 ;;; Commentary:
  28
  29 (require 'font)
  30
  31 (setq GTK_TOPLEVEL              (lsh 1 4)
  32       GTK_NO_WINDOW             (lsh 1 5)
  33       GTK_REALIZED              (lsh 1 6)
  34       GTK_MAPPED                (lsh 1 7)
  35       GTK_VISIBLE               (lsh 1 8)
  36       GTK_SENSITIVE             (lsh 1 9)
  37       GTK_PARENT_SENSITIVE      (lsh 1 10)
  38       GTK_CAN_FOCUS             (lsh 1 11)
  39       GTK_HAS_FOCUS             (lsh 1 12)
  40       GTK_CAN_DEFAULT           (lsh 1 13)
  41       GTK_HAS_DEFAULT           (lsh 1 14)
  42       GTK_HAS_GRAB              (lsh 1 15)
  43       GTK_RC_STYLE              (lsh 1 16)
  44       GTK_COMPOSITE_CHILD       (lsh 1 17)
  45       GTK_NO_REPARENT           (lsh 1 18)
  46       GTK_APP_PAINTABLE         (lsh 1 19)
  47       GTK_RECEIVES_DEFAULT      (lsh 1 20))
  48
  49 (defun gtk-widget-visible (widget)
  50   (= (logand (gtk-object-flags widget) GTK_VISIBLE) GTK_VISIBLE))
  51
  52 (defvar gtk-defined-tests nil
  53   "A list describing the defined tests.
  54 Each element is of the form (DESCRIPTION TYPE FUNCTION)")
  55
  56 (defvar gtk-test-directory nil)
  57 (defun gtk-test-directory ()
  58   (if (not gtk-test-directory)
  59       (mapc (lambda (c)
  60               (if (and (not gtk-test-directory)
  61                        (string= (file-name-nondirectory (car c)) "gtk-test.el"))
  62                   (setq gtk-test-directory (file-name-directory (car c)))))
  63             load-history))
  64   gtk-test-directory)
  65
  66 (defvar gtk-test-categories '((container . "Containers")
  67                               (basic     . "Basic Widgets")
  68                               (composite . "Composite Widgets")
  69                               (gimp      . "Gimp Widgets")
  70                               (misc      . "Miscellaneous")
  71                               (extra     . "GTK+ Extra")
  72                               (gdk       . "GDK Primitives")
  73                               (gnome     . "GNOME tests"))
  74   "An assoc list mapping test categories to friendly names.")
  75
  76 (defvar gtk-test-open-glyph
  77   (make-glyph [xpm :data "/* XPM */\nstatic char * book_open_xpm[] = {\n\"16 16 4 1\",\n\"       c None s None\",\n\".      c black\",\n\"X      c #808080\",\n\"o      c white\",\n\"                \",\n\"  ..            \",\n\" .Xo.    ...    \",\n\" .Xoo. ..oo.    \",\n\" .Xooo.Xooo...  \",\n\" .Xooo.oooo.X.  \",\n\" .Xooo.Xooo.X.  \",\n\" .Xooo.oooo.X.  \",\n\" .Xooo.Xooo.X.  \",\n\" .Xooo.oooo.X.  \",\n\"  .Xoo.Xoo..X.  \",\n\"   .Xo.o..ooX.  \",\n\"    .X..XXXXX.  \",\n\"    ..X.......  \",\n\"     ..         \",\n\"                \"};"]))
  78
  79 (defvar gtk-test-closed-glyph
  80   (make-glyph [xpm :data "/* XPM */\nstatic char * book_closed_xpm[] = {\n\"16 16 6 1\",\n\"       c None s None\",\n\".      c black\",\n\"X      c red\",\n\"o      c yellow\",\n\"O      c #808080\",\n\"#      c white\",\n\"                \",\n\"       ..       \",\n\"     ..XX.      \",\n\"   ..XXXXX.     \",\n\" ..XXXXXXXX.    \",\n\".ooXXXXXXXXX.   \",\n\"..ooXXXXXXXXX.  \",\n\".X.ooXXXXXXXXX. \",\n\".XX.ooXXXXXX..  \",\n\" .XX.ooXXX..#O  \",\n\"  .XX.oo..##OO. \",\n\"   .XX..##OO..  \",\n\"    .X.#OO..    \",\n\"     ..O..      \",\n\"      ..        \",\n\"                \"};\n"]))
  81
  82 (defvar gtk-test-mini-page-glyph
  83   (make-glyph [xpm :data "/* XPM */\nstatic char * mini_page_xpm[] = {\n\"16 16 4 1\",\n\"       c None s None\",\n\".      c black\",\n\"X      c white\",\n\"o      c #808080\",\n\"                \",\n\"   .......      \",\n\"   .XXXXX..     \",\n\"   .XoooX.X.    \",\n\"   .XXXXX....   \",\n\"   .XooooXoo.o  \",\n\"   .XXXXXXXX.o  \",\n\"   .XooooooX.o  \",\n\"   .XXXXXXXX.o  \",\n\"   .XooooooX.o  \",\n\"   .XXXXXXXX.o  \",\n\"   .XooooooX.o  \",\n\"   .XXXXXXXX.o  \",\n\"   ..........o  \",\n\"    oooooooooo  \",\n\"                \"};\n"]))
  84
  85 (defvar gtk-test-mini-gtk-glyph
  86   (make-glyph [xpm :data "/* XPM */\nstatic char * gtk_mini_xpm[] = {\n\"15 20 17 1\",\n\"       c None\",\n\".      c #14121F\",\n\"+      c #278828\",\n\"@      c #9B3334\",\n\"#      c #284C72\",\n\"$      c #24692A\",\n\"%      c #69282E\",\n\"&      c #37C539\",\n\"*      c #1D2F4D\",\n\"=      c #6D7076\",\n\"-      c #7D8482\",\n\";      c #E24A49\",\n\">      c #515357\",\n\",      c #9B9C9B\",\n\"'      c #2FA232\",\n\")      c #3CE23D\",\n\"!      c #3B6CCB\",\n\"               \",\n\"      ***>     \",\n\"    >.*!!!*    \",\n\"   ***....#*=  \",\n\"  *!*.!!!**!!# \",\n\" .!!#*!#*!!!!# \",\n\" @%#!.##.*!!$& \",\n\" @;%*!*.#!#')) \",\n\" @;;@%!!*$&)'' \",\n\" @%.%@%$'&)$+' \",\n\" @;...@$'*'*)+ \",\n\" @;%..@$+*.')$ \",\n\" @;%%;;$+..$)# \",\n\" @;%%;@$$$'.$# \",\n\" %;@@;;$$+))&* \",\n\"  %;;;@+$&)&*  \",\n\"   %;;@'))+>   \",\n\"    %;@'&#     \",\n\"     >%$$      \",\n\"      >=       \"};"]))
  87
  88
  89 (defun build-option-menu (items history obj)
  90   (let (omenu menu menu-item group i)
  91     (setq omenu (gtk-option-menu-new)
  92           menu (gtk-menu-new)
  93           i 0)
  94
  95     (while items
  96       (setq menu-item (gtk-radio-menu-item-new-with-label group (car (car items))))
  97       (gtk-signal-connect menu-item 'activate (cdr (car items)) obj)
  98       (setq group (gtk-radio-menu-item-group menu-item))
  99       (gtk-menu-append menu menu-item)
 100       (if (= i history)
 101           (gtk-check-menu-item-set-active menu-item t))
 102       (gtk-widget-show menu-item)
 103       (setq items (cdr items))
 104       (incf i))
 105
 106     (gtk-option-menu-set-menu omenu menu)
 107     (gtk-option-menu-set-history omenu history)
 108     omenu))
 109
 110 (defun gtk-test-notice-destroy (object symbol)
 111   ;; Set variable to NIL to aid in object destruction.
 112   (set symbol nil))
 113
 114 (defun gtk-test-make-sample-buttons (box maker)
 115   ;; Create buttons and pack them in a premade BOX.
 116   (mapcar (lambda (name)
 117             (let ((button (funcall maker name)))
 118               (gtk-box-pack-start box button t t 0)
 119               (gtk-widget-show button)
 120               button)) '("button1" "button2" "button3")))
 121
 122 (make-face 'gtk-test-face-large "A face with a large font, for use in GTK test cases")
 123 (font-set-face-font 'gtk-test-face-large
 124                (make-font :family '("LucidaBright" "Utopia" "Helvetica" "fixed")
 125                           :weight :normal
 126                           :size "36pt"))
 127
 128 (defvar gtk-test-shell nil
 129   "Where non-dialog tests should realize their widgets.")
 130
 131 (defmacro gtk-define-test (title type name-stub dialog-p &rest body)
 132   "Define a GTK demo/test.
 133 TITLE is the friendly name of the test to show to the user.
 134 TYPE is used to sort the items.
 135 NAME-STUB is used to create the function definition.
 136 DIALOG-P must be non-nil for demos that create their own top-level window.
 137 BODY are the forms that actually create the demo.
 138
 139 They must pack their widgets into the dynamically bound WINDOW variable,
 140 which is a GtkVBox.
 141 "
 142   `(progn
 143      (if (not (assoc ,title gtk-defined-tests))
 144          (push (list ,title (quote ,type)
 145                      (quote ,(intern (format "gtk-test-%s" name-stub)))) gtk-defined-tests))
 146      (defun ,(intern (format "gtk-test-%s" name-stub)) ()
 147        (let ((main-widget (if (not gtk-test-shell)
 148                               (gtk-window-new 'toplevel)
 149                             (gtk-frame-new ,title)))
 150              (window nil))
 151          (if gtk-test-shell
 152              (progn
 153                (mapc 'gtk-widget-destroy (gtk-container-children gtk-test-shell))
 154                (gtk-box-pack-start gtk-test-shell main-widget nil nil 0))
 155            (gtk-window-set-title main-widget ,title))
 156          (if ,dialog-p
 157              (let ((button (gtk-button-new-with-label ,title))
 158                    (blank (gtk-event-box-new)))
 159                (setq window (gtk-hbox-new nil 0))
 160                (gtk-signal-connect button 'clicked
 161                                    (lambda (&rest ignored)
 162                                      (let ((window nil))
 163                                        ,@body
 164                                        (gtk-widget-show-all window))))
 165                (gtk-box-pack-start window
 166                                    (gtk-label-new
 167                                     (concat "This demo creates an external dialog.\n"
 168                                             "Activate the button to see the demo."))
 169                                    nil nil 0)
 170                (gtk-box-pack-start window button nil nil 0)
 171                (gtk-box-pack-start window blank t t 0)
 172                (gtk-widget-show-all main-widget))
 173            (setq window (gtk-vbox-new nil 0))
 174            ,@body)
 175          (gtk-container-add main-widget window)
 176          (gtk-widget-show-all (or main-widget window))))))
 177
 178 \f
 179 ;;;; Pixmaps
 180 (gtk-define-test
 181   "Pixmaps" misc pixmap nil
 182   (let* ((button (gtk-button-new))
 183          (pixmap (gtk-pixmap-new xemacs-logo nil))
 184          (label (gtk-label-new "Pixmap test"))
 185          (hbox (gtk-hbox-new nil 0)))
 186     (gtk-box-pack-start window button nil nil 0)
 187     (gtk-widget-show button)
 188     (gtk-container-set-border-width hbox 2)
 189     (gtk-container-add hbox pixmap)
 190     (gtk-container-add hbox label)
 191     (gtk-container-add button hbox)
 192     (gtk-widget-show pixmap)
 193     (gtk-widget-show label)
 194     (gtk-widget-show hbox)))
 195
 196 \f
 197 ;;;; Scrolled windows
 198 (gtk-define-test
 199  "Scrolled windows" container create-scrolled-windows nil
 200  (let* ((scrolled-win (gtk-scrolled-window-new nil nil))
 201         (viewport (gtk-viewport-new
 202                    (gtk-scrolled-window-get-hadjustment scrolled-win)
 203                    (gtk-scrolled-window-get-vadjustment scrolled-win)))
 204         (table (gtk-table-new 20 20 nil))
 205         (button nil))
 206    (gtk-container-set-border-width window 0)
 207    (gtk-container-set-border-width scrolled-win 10)
 208    (gtk-scrolled-window-set-policy scrolled-win 'automatic 'automatic)
 209    (gtk-box-pack-start window scrolled-win t t 0)
 210    (gtk-table-set-row-spacings table 10)
 211    (gtk-table-set-col-spacings table 10)
 212    (gtk-scrolled-window-add-with-viewport scrolled-win table)
 213    (gtk-container-set-focus-hadjustment
 214     table (gtk-scrolled-window-get-hadjustment scrolled-win))
 215    (gtk-container-set-focus-vadjustment
 216     table (gtk-scrolled-window-get-vadjustment scrolled-win))
 217    (loop for i from 0 to 19 do
 218      (loop for j from 0 to 19 do
 219        (setq button (gtk-button-new-with-label (format "button (%d, %d)\n" i j)))
 220        (gtk-table-attach-defaults table button i (1+ i) j (1+ j))))
 221    (gtk-widget-show-all scrolled-win)))
 222
 223 \f
 224 ;;;; Lists
 225 (gtk-define-test
 226  "List" basic create-list nil
 227  (let ((list-items '("hello"
 228                      "world"
 229                      "blah"
 230                      "foo"
 231                      "bar"
 232                      "argh"
 233                      "wmperry"
 234                      "is a"
 235                      "wussy"
 236                      "programmer"))
 237        (scrolled-win (gtk-scrolled-window-new nil nil))
 238        (lyst (gtk-list-new))
 239        (add (gtk-button-new-with-label "add"))
 240        (remove (gtk-button-new-with-label "remove")))
 241
 242    (gtk-scrolled-window-set-policy scrolled-win 'automatic 'automatic)
 243    (gtk-box-pack-start window scrolled-win t t 0)
 244    (gtk-widget-show scrolled-win)
 245
 246    (gtk-list-set-selection-mode lyst 'multiple)
 247    (gtk-list-set-selection-mode lyst 'browse)
 248    (gtk-scrolled-window-add-with-viewport scrolled-win lyst)
 249    (gtk-widget-show lyst)
 250
 251    (mapc (lambda (i)
 252            (let ((list-item (gtk-list-item-new-with-label i)))
 253              (gtk-container-add lyst list-item)
 254              (gtk-widget-show list-item)))
 255          list-items)
 256
 257    (gtk-signal-connect add 'clicked
 258                        (lambda (obj data) (message "Should add to the list")))
 259    (gtk-box-pack-start window add nil t 0)
 260    (gtk-widget-show add)
 261
 262    (gtk-signal-connect remove 'clicked
 263                        (lambda (obj list)
 264                          (if (gtk-list-selection list)
 265                              (gtk-list-remove-items list (gtk-list-selection list)))) lyst)
 266    (gtk-box-pack-start window remove nil t 0)
 267    (gtk-widget-show remove)
 268
 269    (gtk-signal-connect lyst 'select_child
 270                        (lambda (lyst child ignored)
 271                          (message "selected %S %d" child (gtk-list-child-position lyst child))))
 272
 273    (gtk-widget-set-usize scrolled-win 200 75)
 274
 275    (gtk-signal-connect lyst 'unselect_child (lambda (lyst child ignored)
 276                                               (message "unselected %S" child)))))
 277
 278 \f
 279 ;;;; Tooltips
 280 (defvar gtk-test-tooltips nil)
 281
 282 (gtk-define-test
 283  "Tooltips" composite create-tooltips nil
 284   (if (not gtk-test-tooltips)
 285       (setq gtk-test-tooltips (gtk-tooltips-new)))
 286   (let ((buttons (gtk-test-make-sample-buttons window 'gtk-toggle-button-new-with-label))
 287         (tips '("This is button 1"
 288                 "This is button 2"
 289                 "This is button 3. This is also a really long tooltip which probably won't fit on a single line and will therefore need to be wrapped. Hopefully the wrapping will work correctly.")))
 290     (while buttons
 291       (gtk-tooltips-set-tip gtk-test-tooltips (pop buttons) (pop tips) ""))))
 292
 293 \f
 294 ;;;; Panes
 295 (defun toggle-resize (widget child)
 296   (let* ((paned (gtk-widget-parent child))
 297          (is-child1 (eq child (gtk-paned-child1 paned)))
 298          resize shrink)
 299     (setq resize (if is-child1
 300                      (gtk-paned-child1-resize paned)
 301                    (gtk-paned-child2-resize paned))
 302           shrink (if is-child1
 303                      (gtk-paned-child1-shrink paned)
 304                    (gtk-paned-child2-shrink paned)))
 305
 306     (gtk-widget-ref child)
 307     (gtk-container-remove paned child)
 308     (if is-child1
 309         (gtk-paned-pack1 paned child (not resize) shrink)
 310       (gtk-paned-pack2 paned child (not resize) shrink))
 311     (gtk-widget-unref child)))
 312
 313 (defun toggle-shrink (widget child)
 314   (let* ((paned (gtk-widget-parent child))
 315          (is-child1 (eq child (gtk-paned-child1 paned)))
 316          resize shrink)
 317     (setq resize (if is-child1
 318                      (gtk-paned-child1-resize paned)
 319                    (gtk-paned-child2-resize paned))
 320           shrink (if is-child1
 321                      (gtk-paned-child1-shrink paned)
 322                    (gtk-paned-child2-shrink paned)))
 323
 324     (gtk-widget-ref child)
 325     (gtk-container-remove paned child)
 326     (if is-child1
 327         (gtk-paned-pack1 paned child resize (not shrink))
 328       (gtk-paned-pack2 paned child resize (not shrink)))
 329     (gtk-widget-unref child)))
 330
 331 (defun create-pane-options (widget frame-label label1 label2)
 332   (let (frame table label check-button)
 333     (setq frame (gtk-frame-new frame-label))
 334     (gtk-container-set-border-width frame 4)
 335
 336     (setq table (gtk-table-new 3 2 4))
 337     (gtk-container-add frame table)
 338
 339     (setq label (gtk-label-new label1))
 340     (gtk-table-attach-defaults table label 0 1 0 1)
 341
 342     (setq check-button (gtk-check-button-new-with-label "Resize"))
 343     (gtk-table-attach-defaults table check-button 0 1 1 2)
 344     (gtk-signal-connect check-button 'toggled 'toggle-resize (gtk-paned-child1 widget))
 345
 346     (setq check-button (gtk-check-button-new-with-label "Shrink"))
 347     (gtk-table-attach-defaults table check-button 0 1 2 3)
 348     (gtk-toggle-button-set-active check-button t)
 349     (gtk-signal-connect check-button 'toggled 'toggle-shrink (gtk-paned-child1 widget))
 350
 351     (setq label (gtk-label-new label2))
 352     (gtk-table-attach-defaults table label 1 2 0 1)
 353
 354     (setq check-button (gtk-check-button-new-with-label "Resize"))
 355     (gtk-table-attach-defaults table check-button 1 2 1 2)
 356     (gtk-toggle-button-set-active check-button t)
 357     (gtk-signal-connect check-button 'toggled 'toggle-resize (gtk-paned-child2 widget))
 358
 359     (setq check-button (gtk-check-button-new-with-label "Shrink"))
 360     (gtk-table-attach-defaults table check-button 1 2 2 3)
 361     (gtk-toggle-button-set-active check-button t)
 362     (gtk-signal-connect check-button 'toggled 'toggle-shrink (gtk-paned-child2 widget))
 363     frame))
 364
 365 (gtk-define-test
 366  "Panes" container panes nil
 367  (let (frame hpaned vpaned button vbox)
 368    (gtk-container-set-border-width window 0)
 369
 370    (setq vpaned (gtk-vpaned-new))
 371    (gtk-box-pack-start window vpaned t t 0)
 372    (gtk-container-set-border-width vpaned 5)
 373
 374    (setq hpaned (gtk-hpaned-new))
 375    (gtk-paned-add1 vpaned hpaned)
 376
 377    (setq frame (gtk-frame-new nil))
 378    (gtk-frame-set-shadow-type frame 'in)
 379    (gtk-widget-set-usize frame 60 60)
 380    (gtk-paned-add1 hpaned frame)
 381
 382    (setq button (gtk-button-new-with-label "Hi there"))
 383    (gtk-container-add frame button)
 384
 385    (setq frame (gtk-frame-new nil))
 386    (gtk-frame-set-shadow-type frame 'in)
 387    (gtk-widget-set-usize frame 80 60)
 388    (gtk-paned-add2 hpaned frame)
 389
 390    (setq frame (gtk-frame-new nil))
 391    (gtk-frame-set-shadow-type frame 'in)
 392    (gtk-widget-set-usize frame 60 80)
 393    (gtk-paned-add2 vpaned frame)
 394
 395    ;; Now create toggle buttons to control sizing
 396    (gtk-box-pack-start window (create-pane-options hpaned "Horizontal" "Left" "Right") nil nil 0)
 397    (gtk-box-pack-start window (create-pane-options vpaned "Vertical" "Top" "Bottom") nil nil 0)
 398    (gtk-widget-show-all window)))
 399
 400 \f
 401 ;;;; Entry
 402 (gtk-define-test
 403  "Entry" basic entry nil
 404  (let ((box1 nil)
 405        (box2 nil)
 406        (editable-check nil)
 407        (sensitive-check nil)
 408        (entry nil)
 409        (cb nil)
 410        (button nil)
 411        (separator nil)
 412        (cbitems '("item0"
 413                   "item1 item1"
 414                   "item2 item2 item2"
 415                   "item3 item3 item3 item3"
 416                   "item4 item4 item4 item4 item4"
 417                   "item5 item5 item5 item5 item5 item5"
 418                   "item6 item6 item6 item6 item6"
 419                   "item7 item7 item7 item7"
 420                   "item8 item8 item8"
 421                   "item9 item9")))
 422    (gtk-container-set-border-width window 0)
 423
 424    (setq box1 (gtk-vbox-new nil 0))
 425    (gtk-container-add window box1)
 426    (gtk-widget-show box1)
 427
 428    (setq box2 (gtk-vbox-new nil 10))
 429    (gtk-container-set-border-width box2 10)
 430    (gtk-box-pack-start box1 box2 t t 0)
 431    (gtk-widget-show box2)
 432
 433    (setq entry (gtk-entry-new))
 434    (gtk-entry-set-text entry "hello world")
 435    (gtk-editable-select-region entry 0 5)
 436    (gtk-box-pack-start box2 entry t t 0)
 437    (gtk-widget-show entry)
 438
 439    (setq cb (gtk-combo-new))
 440    (gtk-combo-set-popdown-strings cb cbitems)
 441    (gtk-entry-set-text (gtk-combo-entry cb) "hellow world")
 442    (gtk-editable-select-region (gtk-combo-entry cb) 0 -1)
 443    (gtk-box-pack-start box2 cb t t 0)
 444    (gtk-widget-show cb)
 445
 446    (setq editable-check (gtk-check-button-new-with-label "Editable"))
 447    (gtk-box-pack-start box2 editable-check nil t 0)
 448    (gtk-signal-connect editable-check 'toggled
 449                        (lambda (obj data)
 450                          (gtk-entry-set-editable
 451                           data
 452                           (gtk-toggle-button-get-active obj))) entry)
 453    (gtk-toggle-button-set-active editable-check t)
 454    (gtk-widget-show editable-check)
 455
 456    (setq editable-check (gtk-check-button-new-with-label "Visible"))
 457    (gtk-box-pack-start box2 editable-check nil t 0)
 458    (gtk-signal-connect editable-check 'toggled
 459                        (lambda (obj data)
 460                          (gtk-entry-set-visibility data
 461                                                    (gtk-toggle-button-get-active obj))) entry)
 462    (gtk-toggle-button-set-active editable-check t)
 463    (gtk-widget-show editable-check)
 464
 465    (setq sensitive-check (gtk-check-button-new-with-label "Sensitive"))
 466    (gtk-box-pack-start box2 sensitive-check nil t 0)
 467    (gtk-signal-connect sensitive-check 'toggled
 468                        (lambda (obj data)
 469                          (gtk-widget-set-sensitive data
 470                                                    (gtk-toggle-button-get-active obj))) entry)
 471    (gtk-toggle-button-set-active sensitive-check t)
 472    (gtk-widget-show sensitive-check)))
 473
 474 \f
 475 ;;;; Various built-in dialog types
 476 (gtk-define-test
 477  "Font Dialog" composite font-selection t
 478  (setq window (gtk-font-selection-dialog-new "font selection dialog"))
 479  (gtk-font-selection-dialog-set-preview-text window "Set from Emacs Lisp!")
 480  (gtk-signal-connect
 481   (gtk-font-selection-dialog-cancel-button window)
 482   'clicked (lambda (button dlg)
 483              (gtk-widget-destroy dlg))
 484   window)
 485  (gtk-signal-connect
 486   (gtk-font-selection-dialog-ok-button window)
 487   'clicked
 488   (lambda (button dlg)
 489     (message "Font selected: %s" (gtk-font-selection-dialog-get-font-name dlg)))
 490   window))
 491
 492 (gtk-define-test
 493  "File Selection Dialog" composite file-selection t
 494  (let (button)
 495    (setq window (gtk-file-selection-new "file selection"))
 496    (gtk-signal-connect
 497     (gtk-file-selection-ok-button window)
 498     'clicked (lambda (obj dlg) (message "You clicked ok: %s"
 499                                         (gtk-file-selection-get-filename dlg)))
 500     window)
 501
 502     (gtk-signal-connect
 503      (gtk-file-selection-cancel-button window)
 504      'clicked (lambda (obj dlg) (gtk-widget-destroy dlg)) window)
 505
 506     (gtk-file-selection-hide-fileop-buttons window)
 507
 508     (setq button (gtk-button-new-with-label "Hide Fileops"))
 509     (gtk-signal-connect
 510      button 'clicked
 511      (lambda (obj dlg)
 512        (gtk-file-selection-hide-fileop-buttons dlg)) window)
 513
 514     (gtk-box-pack-start (gtk-file-selection-action-area window)
 515                         button nil nil 0)
 516     (gtk-widget-show button)
 517
 518     (setq button (gtk-button-new-with-label "Show Fileops"))
 519     (gtk-signal-connect
 520      button 'clicked
 521      (lambda (obj dlg)
 522        (gtk-file-selection-show-fileop-buttons dlg)) window)
 523     (gtk-box-pack-start (gtk-file-selection-action-area window)
 524                         button nil nil 0)
 525     (gtk-widget-show button)))
 526
 527 (gtk-define-test
 528  "Color selection" composite color t
 529  (setq window (gtk-color-selection-dialog-new "GTK color selection"))
 530  (gtk-signal-connect (gtk-color-selection-dialog-cancel-button window)
 531                      'clicked
 532                      (lambda (button data)
 533                        (gtk-widget-destroy data)) window)
 534  (gtk-signal-connect (gtk-color-selection-dialog-ok-button window)
 535                      'clicked
 536                      (lambda (button data)
 537                        (let ((rgba (gtk-color-selection-get-color
 538                                     (gtk-color-selection-dialog-colorsel data)))
 539                              r g b a)
 540                          (setq r (pop rgba)
 541                                g (pop rgba)
 542                                b (pop rgba)
 543                                a (pop rgba))
 544                          (gtk-widget-destroy data)
 545                          (message-box
 546                           "You selected color: red (%04x) blue (%04x) green (%04x) alpha (%g)"
 547                           (* 65535 r) (* 65535 g) (* 65535 b) a)))
 548                      window))
 549
 550 \f
 551 ;;;; Dialog
 552 (defun gtk-container-specific-children (parent predicate &optional data)
 553   (let ((children nil))
 554     (mapc (lambda (w)
 555             (if (funcall predicate w data)
 556                 (push w children)))
 557           (gtk-container-children parent))
 558     children))
 559
 560 (gtk-define-test
 561  "Dialog" basic dialog t
 562  (let ((button nil)
 563        (label nil))
 564    (setq window (gtk-dialog-new))
 565    (gtk-container-set-border-width window 0)
 566    (gtk-widget-set-usize window 200 110)
 567
 568    (setq button (gtk-button-new-with-label "OK"))
 569    (gtk-box-pack-start (gtk-dialog-action-area window) button t t 0)
 570    (gtk-widget-show button)
 571    (gtk-signal-connect button 'clicked
 572                        (lambda (obj data)
 573                          (gtk-widget-destroy data))
 574                        window)
 575
 576    (setq button (gtk-button-new-with-label "Toggle"))
 577    (gtk-signal-connect
 578     button 'clicked
 579     (lambda (button dlg)
 580       (if (not (gtk-container-specific-children (gtk-dialog-vbox dlg)
 581                                                 (lambda (w ignored)
 582                                                   (= (gtk-object-type w) (gtk-label-get-type)))))
 583           (let ((label (gtk-label-new "Dialog Test")))
 584             (gtk-box-pack-start (gtk-dialog-vbox dlg) label t t 0)
 585             (gtk-widget-show label))
 586         (mapc 'gtk-widget-destroy
 587               (gtk-container-specific-children (gtk-dialog-vbox dlg)
 588                                                (lambda (w ignored)
 589                                                  (= (gtk-object-type w) (gtk-label-get-type)))))))
 590     window)
 591    (gtk-box-pack-start (gtk-dialog-action-area window) button t t 0)
 592    (gtk-widget-show button)))
 593
 594 \f
 595 ;;;; Range controls
 596 (gtk-define-test
 597  "Range Controls" basic range-controls nil
 598  (let* ((adjustment (gtk-adjustment-new 0.0 0.0 101.0 0.1 1.0 1.0))
 599         (scale (gtk-hscale-new adjustment))
 600         (scrollbar (gtk-hscrollbar-new adjustment)))
 601     (gtk-widget-set-usize scale 150 30)
 602     (gtk-range-set-update-policy scale 'delayed)
 603     (gtk-scale-set-digits scale 2)
 604     (gtk-scale-set-draw-value scale t)
 605     (gtk-box-pack-start window scale t t 0)
 606     (gtk-widget-show scale)
 607
 608     (gtk-range-set-update-policy scrollbar 'continuous)
 609     (gtk-box-pack-start window scrollbar t t 0)
 610     (gtk-widget-show scrollbar)))
 611
 612 \f
 613 ;;;; Ruler
 614 '(gtk-define-test
 615  "Rulers" gimp rulers nil
 616  (let* ((table (gtk-table-new 2 2 nil))
 617         (hruler nil)
 618         (vruler nil)
 619         (ebox (gtk-event-box-new)))
 620
 621    (gtk-widget-set-usize ebox 300 300)
 622    (gtk-widget-set-events ebox '(pointer-motion-mask pointer-motion-hint-mask))
 623    (gtk-container-set-border-width ebox 0)
 624
 625    (gtk-container-add window ebox)
 626    (gtk-container-add ebox table)
 627    (gtk-widget-show table)
 628
 629    (setq hruler (gtk-hruler-new))
 630    (gtk-ruler-set-metric hruler 'centimeters)
 631    (gtk-ruler-set-range hruler 100 0 0 20)
 632    (gtk-table-attach table hruler 1 2 0 1 '(expand fill) 'fill 0 0)
 633    (gtk-widget-show hruler)
 634
 635    (setq vruler (gtk-vruler-new))
 636    (gtk-ruler-set-range vruler 5 15 0 20)
 637    (gtk-table-attach table vruler 0 1 1 2 'fill '(expand fill) 0 0)
 638    (gtk-widget-show vruler)
 639
 640    (gtk-signal-connect
 641     ebox 'motion_notify_event
 642     (lambda (object ev data)
 643       (gtk-widget-event (car data) ev)
 644       (gtk-widget-event (cdr data) ev))
 645     (cons hruler vruler))))
 646
 647 \f
 648 ;;;; Toggle button types
 649 (gtk-define-test
 650  "Toggle Buttons" basic toggle-buttons nil
 651  (gtk-container-set-border-width window 0)
 652  (gtk-test-make-sample-buttons window 'gtk-toggle-button-new-with-label))
 653
 654 (gtk-define-test
 655  "Check Buttons" basic check-buttons nil
 656  (gtk-container-set-border-width window 0)
 657  (gtk-test-make-sample-buttons window 'gtk-check-button-new-with-label))
 658
 659 (gtk-define-test
 660  "Radio Buttons" basic radio-buttons nil
 661  (gtk-container-set-border-width window 0)
 662  (let ((group nil))
 663    (gtk-test-make-sample-buttons window
 664                                  (lambda (label)
 665                                    (let ((button (gtk-radio-button-new-with-label group label)))
 666                                      (setq group (gtk-radio-button-group button))
 667                                      button)))))
 668
 669 \f
 670 ;;;; Button weirdness
 671 (gtk-define-test
 672  "Buttons" basic buttons nil
 673  (let ((box1 nil)
 674        (box2 nil)
 675        (table nil)
 676        (buttons nil)
 677        (separator nil)
 678        (connect-buttons (lambda (button1 button2)
 679                           (gtk-signal-connect button1 'clicked
 680                                               (lambda (obj data)
 681                                                 (if (gtk-widget-visible data)
 682                                                     (gtk-widget-hide data)
 683                                                   (gtk-widget-show data))) button2))))
 684
 685    (gtk-container-set-border-width window 0)
 686
 687    (setq box1 (gtk-vbox-new nil 0))
 688    (gtk-container-add window box1)
 689
 690    (setq table (gtk-table-new 3 3 nil))
 691    (gtk-table-set-row-spacings table 5)
 692    (gtk-table-set-col-spacings table 5)
 693    (gtk-container-set-border-width table 10)
 694    (gtk-box-pack-start box1 table t t 0)
 695
 696    (push (gtk-button-new-with-label "button9") buttons)
 697    (push (gtk-button-new-with-label "button8") buttons)
 698    (push (gtk-button-new-with-label "button7") buttons)
 699    (push (gtk-button-new-with-label "button6") buttons)
 700    (push (gtk-button-new-with-label "button5") buttons)
 701    (push (gtk-button-new-with-label "button4") buttons)
 702    (push (gtk-button-new-with-label "button3") buttons)
 703    (push (gtk-button-new-with-label "button2") buttons)
 704    (push (gtk-button-new-with-label "button1") buttons)
 705
 706    (funcall connect-buttons (nth 0 buttons) (nth 1 buttons))
 707    (funcall connect-buttons (nth 1 buttons) (nth 2 buttons))
 708    (funcall connect-buttons (nth 2 buttons) (nth 3 buttons))
 709    (funcall connect-buttons (nth 3 buttons) (nth 4 buttons))
 710    (funcall connect-buttons (nth 4 buttons) (nth 5 buttons))
 711    (funcall connect-buttons (nth 5 buttons) (nth 6 buttons))
 712    (funcall connect-buttons (nth 6 buttons) (nth 7 buttons))
 713    (funcall connect-buttons (nth 7 buttons) (nth 8 buttons))
 714    (funcall connect-buttons (nth 8 buttons) (nth 0 buttons))
 715
 716    (gtk-table-attach table (nth 0 buttons) 0 1 0 1 '(expand fill) '(expand fill) 0 0)
 717    (gtk-table-attach table (nth 1 buttons) 1 2 1 2 '(expand fill) '(expand fill) 0 0)
 718    (gtk-table-attach table (nth 2 buttons) 2 3 2 3 '(expand fill) '(expand fill) 0 0)
 719    (gtk-table-attach table (nth 3 buttons) 0 1 2 3 '(expand fill) '(expand fill) 0 0)
 720    (gtk-table-attach table (nth 4 buttons) 2 3 0 1 '(expand fill) '(expand fill) 0 0)
 721    (gtk-table-attach table (nth 5 buttons) 1 2 2 3 '(expand fill) '(expand fill) 0 0)
 722    (gtk-table-attach table (nth 6 buttons) 1 2 0 1 '(expand fill) '(expand fill) 0 0)
 723    (gtk-table-attach table (nth 7 buttons) 2 3 1 2 '(expand fill) '(expand fill) 0 0)
 724    (gtk-table-attach table (nth 8 buttons) 0 1 1 2 '(expand fill) '(expand fill) 0 0)
 725    ))
 726
 727 \f
 728 ;;;; Testing labels and underlining
 729 (gtk-define-test
 730  "Labels" basic labels nil
 731  (let ((hbox (gtk-hbox-new nil 5))
 732        (vbox (gtk-vbox-new nil 5))
 733        (frame nil)
 734        (label nil))
 735    (gtk-container-add window hbox)
 736    (gtk-box-pack-start hbox vbox nil nil 0)
 737    (gtk-container-set-border-width window 5)
 738
 739    (setq frame (gtk-frame-new "Normal Label")
 740          label (gtk-label-new "This is a Normal label"))
 741    (gtk-container-add frame label)
 742    (gtk-box-pack-start vbox frame nil nil 0)
 743
 744    (setq frame (gtk-frame-new "Multi-line Label")
 745          label (gtk-label-new "This is a multi-line label.\nSecond line\nThird line"))
 746    (gtk-container-add frame label)
 747    (gtk-box-pack-start vbox frame nil nil 0)
 748
 749    (setq frame (gtk-frame-new "Left Justified Label")
 750          label (gtk-label-new "This is a Left-Justified\nMulti-line label.\nThird      line"))
 751    (gtk-label-set-justify label 'left)
 752    (gtk-container-add frame label)
 753    (gtk-box-pack-start vbox frame nil nil 0)
 754
 755    (setq frame (gtk-frame-new "Right Justified Label")
 756          label (gtk-label-new "This is a Right-Justified\nMulti-line label.\nFourth line, (j/k)"))
 757    (gtk-label-set-justify label 'right)
 758    (gtk-container-add frame label)
 759    (gtk-box-pack-start vbox frame nil nil 0)
 760
 761    ;; Start a second row so that we don't make a ridiculously tall window
 762    (setq vbox (gtk-vbox-new nil 5))
 763    (gtk-box-pack-start hbox vbox nil nil 0)
 764
 765    (setq frame (gtk-frame-new "Line wrapped label")
 766          label (gtk-label-new
 767                 (concat "This is an example of a line-wrapped label.  It should not be taking "
 768                         "up the entire             " ;;; big space to test spacing
 769                         "width allocated to it, but automatically wraps the words to fit.  "
 770                         "The time has come, for all good men, to come to the aid of their party.  "
 771                         "The sixth sheik's six sheep's sick.\n"
 772                         "     It supports multiple paragraphs correctly, and  correctly   adds "
 773                         "many          extra  spaces. ")))
 774    (gtk-label-set-line-wrap label t)
 775    (gtk-container-add frame label)
 776    (gtk-box-pack-start vbox frame nil nil 0)
 777
 778    (setq frame (gtk-frame-new "Filled, wrapped label")
 779          label (gtk-label-new
 780                 (concat
 781                  "This is an example of a line-wrapped, filled label.  It should be taking "
 782                  "up the entire              width allocated to it.  Here is a seneance to prove "
 783                  "my point.  Here is another sentence. "
 784                  "Here comes the sun, do de do de do.\n"
 785                  "    This is a new paragraph.\n"
 786                  "    This is another newer, longer, better paragraph.  It is coming to an end, "
 787                  "unfortunately.")))
 788    (gtk-label-set-justify label 'fill)
 789    (gtk-label-set-line-wrap label t)
 790    (gtk-container-add frame label)
 791    (gtk-box-pack-start vbox frame nil nil 0)
 792
 793    (setq frame (gtk-frame-new "Underlined label")
 794          label (gtk-label-new (concat "This label is underlined!\n"
 795                                       "This one is underlined in ÆüËÜ¸ì¤ÎÆþÍÑquite a funky fashion")))
 796    (gtk-label-set-justify label 'left)
 797    (gtk-label-set-pattern label "_________________________ _ _________ _ _____ _ __ __  ___ ____ _____")
 798    (gtk-container-add frame label)
 799    (gtk-box-pack-start vbox frame nil nil 0)))
 800
 801 \f
 802 ;;;; Progress gauges
 803 (gtk-define-test
 804  "Progress bars" basic progress nil
 805  (let* ((timer nil)
 806         (adj (gtk-adjustment-new 1 0 100 1 1 1))
 807         (label (gtk-label-new "progress..."))
 808         (pbar (gtk-progress-bar-new-with-adjustment adj))
 809         (button nil)
 810         (timer (make-itimer)))
 811
 812    ;; The original test used GTK timers, but XEmacs already has
 813    ;; perfectly good timer support, that ends up mapping onto GTK
 814    ;; timers anyway, so we'll use those instead.
 815    (set-itimer-function
 816     timer
 817     (lambda (bar adj)
 818       (let ((val (gtk-adjustment-value adj)))
 819         (setq val (+ 1 (if (>= val 100) 0 val)))
 820         (gtk-adjustment-set-value adj val)
 821         (gtk-widget-queue-draw bar))))
 822
 823    (set-itimer-function-arguments timer (list pbar adj))
 824    (set-itimer-uses-arguments timer t)
 825    (set-itimer-restart timer 0.1)
 826    (set-itimer-value timer 0.1)
 827    (set-itimer-is-idle timer nil)
 828
 829    (gtk-progress-set-format-string pbar "%v%%")
 830    (gtk-signal-connect pbar 'destroy (lambda (obj timer)
 831                                        (delete-itimer timer)) timer)
 832
 833    (gtk-misc-set-alignment label 0 0.5)
 834    (gtk-box-pack-start window label nil t 0)
 835    (gtk-widget-show label)
 836    (gtk-widget-set-usize pbar 200 20)
 837    (gtk-box-pack-start window pbar t t 0)
 838
 839    (setq button (gtk-check-button-new-with-label "Show text"))
 840    (gtk-box-pack-start window button nil nil 0)
 841    (gtk-signal-connect button 'clicked
 842                        (lambda (button bar)
 843                          (gtk-progress-set-show-text
 844                           bar
 845                           (gtk-toggle-button-get-active button))) pbar)
 846    (gtk-widget-show button)
 847
 848    (setq button (gtk-check-button-new-with-label "Discrete blocks"))
 849    (gtk-box-pack-start window button nil nil 0)
 850    (gtk-signal-connect button 'clicked
 851                        (lambda (button bar)
 852                          (gtk-progress-bar-set-bar-style
 853                           bar
 854                           (if (gtk-toggle-button-get-active button)
 855                               'discrete
 856                             'continuous))) pbar)
 857    (gtk-widget-show button)
 858
 859    (gtk-widget-show pbar)
 860
 861    (activate-itimer timer)))
 862
 863 (gtk-define-test
 864  "Gamma Curve" gimp gamma-curve nil
 865  (let ((curve (gtk-gamma-curve-new)))
 866    (gtk-container-add window curve)
 867    (gtk-widget-show-all curve)
 868    (gtk-curve-set-range (gtk-gamma-curve-curve curve) 0 255 0 255)
 869    (gtk-curve-set-gamma (gtk-gamma-curve-curve curve) 2)))
 870
 871 \f
 872 ;;;; Testing various button boxes and layout strategies.
 873 (gtk-define-test
 874  "Button Box" container button-box nil
 875  (let ((main-vbox (gtk-vbox-new nil 0))
 876        (vbox (gtk-vbox-new nil 0))
 877        (hbox (gtk-hbox-new nil 0))
 878        (frame-horz (gtk-frame-new "Horizontal Button Boxes"))
 879        (frame-vert (gtk-frame-new "Vertical Button Boxes"))
 880        (create-bbox (lambda (horizontal title spacing child-w child-h layout)
 881                       (let ((frame (gtk-frame-new title))
 882                             (bbox (if horizontal
 883                                       (gtk-hbutton-box-new)
 884                                     (gtk-vbutton-box-new))))
 885                         (gtk-container-set-border-width bbox 5)
 886                         (gtk-container-add frame bbox)
 887                         (gtk-button-box-set-layout bbox layout)
 888                         (gtk-button-box-set-spacing bbox spacing)
 889                         (gtk-button-box-set-child-size bbox child-w child-h)
 890                         (gtk-container-add bbox (gtk-button-new-with-label "OK"))
 891                         (gtk-container-add bbox (gtk-button-new-with-label "Cancel"))
 892                         (gtk-container-add bbox (gtk-button-new-with-label "Help"))
 893                         frame))))
 894
 895    (gtk-container-set-border-width window 10)
 896    (gtk-container-add window main-vbox)
 897
 898    (gtk-box-pack-start main-vbox frame-horz t t 10)
 899    (gtk-container-set-border-width vbox 10)
 900    (gtk-container-add frame-horz vbox)
 901
 902    (gtk-box-pack-start main-vbox frame-vert t t 10)
 903    (gtk-container-set-border-width hbox 10)
 904    (gtk-container-add frame-vert hbox)
 905
 906    (gtk-box-pack-start vbox (funcall create-bbox t "Spread" 40 85 20 'spread) t t 0)
 907    (gtk-box-pack-start vbox (funcall create-bbox t "Edge" 40 85 20 'edge) t t 0)
 908    (gtk-box-pack-start vbox (funcall create-bbox t "Start" 40 85 20 'start) t t 0)
 909    (gtk-box-pack-start vbox (funcall create-bbox t "End" 40 85 20 'end) t t 0)
 910
 911    (gtk-box-pack-start hbox (funcall create-bbox nil "Spread" 40 85 20 'spread) t t 0)
 912    (gtk-box-pack-start hbox (funcall create-bbox nil "Edge" 40 85 20 'edge) t t 0)
 913    (gtk-box-pack-start hbox (funcall create-bbox nil "Start" 40 85 20 'start) t t 0)
 914    (gtk-box-pack-start hbox (funcall create-bbox nil "End" 40 85 20 'end) t t 0)))
 915
 916 \f
 917 ;;;; Cursors
 918 '(gtk-define-test
 919   "Cursors" cursors nil
 920   (let ((cursors '(x-cursor arrow based-arrow-down based-arrow-up boat bogosity
 921                             bottom-left-corner bottom-right-corner bottom-side bottom-tee
 922                             box-spiral center-ptr circle clock coffee-mug cross cross-reverse
 923                             crosshair diamond-cross dot dotbox double-arrow draft-large
 924                             draft-small draped-box exchange fleur gobbler gumby hand1 hand2 heart
 925                             icon iron-cross left-ptr left-side left-tee leftbutton ll-angle
 926                             lr-angle man middlebutton mouse pencil pirate plus question-arrow
 927                             right-ptr right-side right-tee rightbutton rtl-logo sailboat
 928                             sb-down-arrow sb-h-double-arrow sb-left-arrow sb-right-arrow
 929                             sb-up-arrow sb-v-double-arrow shuttle sizing spider spraycan star
 930                             target tcross top-left-arrow top-left-corner top-right-corner top-side
 931                             top-tee trek ul-angle umbrella ur-angle watch xterm last-cursor))
 932         (cursor-area nil)
 933         (adjustment nil)
 934         (spinner nil))
 935     (setq cursor-area (gtk-event-box-new)
 936           adjustment (gtk-adjustment-new 0 0 (length cursors) 1 1 1)
 937           spinner (gtk-spin-button-new adjustment 1 3))
 938     (gtk-widget-set-usize cursor-area 200 100)
 939     (gtk-box-pack-start window cursor-area t t 0)
 940     (gtk-box-pack-start window spinner nil nil 0)))
 941
 942 \f
 943 ;;;; Toolbar
 944 (defun gtk-test-toolbar-create ()
 945   (let ((toolbar (gtk-toolbar-new 'horizontal 'both)))
 946     (gtk-toolbar-set-button-relief toolbar 'none)
 947
 948     (gtk-toolbar-append-item toolbar
 949                              "Horizonal" "Horizontal toolbar layout" "Toolbar/Horizontal"
 950                              (gtk-pixmap-new gtk-test-open-glyph nil)
 951                              (lambda (tbar)
 952                                (gtk-toolbar-set-orientation tbar 'horizontal)) toolbar)
 953     (gtk-toolbar-append-item toolbar
 954                              "Vertical" "Vertical toolbar layout" "Toolbar/Vertical"
 955                              (gtk-pixmap-new gtk-test-open-glyph nil)
 956                              (lambda (tbar)
 957                                (gtk-toolbar-set-orientation tbar 'vertical)) toolbar)
 958
 959     (gtk-toolbar-append-space toolbar)
 960     (gtk-toolbar-append-item toolbar
 961                              "Icons" "Only show toolbar icons" "Toolbar/IconsOnly"
 962                              (gtk-pixmap-new gtk-test-open-glyph nil)
 963                              (lambda (tbar)
 964                                (gtk-toolbar-set-style tbar 'icons)) toolbar)
 965     (gtk-toolbar-append-item toolbar
 966                              "Text" "Only show toolbar text" "Toolbar/TextOnly"
 967                              (gtk-pixmap-new gtk-test-open-glyph nil)
 968                              (lambda (tbar)
 969                                (gtk-toolbar-set-style tbar 'text)) toolbar)
 970     (gtk-toolbar-append-item toolbar
 971                              "Both" "Show toolbar icons and text" "Toolbar/Both"
 972                              (gtk-pixmap-new gtk-test-open-glyph nil)
 973                              (lambda (tbar)
 974                                (gtk-toolbar-set-style tbar 'both)) toolbar)
 975
 976     (gtk-toolbar-append-space toolbar)
 977     (gtk-toolbar-append-item toolbar
 978                              "Small" "Use small spaces" ""
 979                              (gtk-pixmap-new gtk-test-open-glyph nil)
 980                              (lambda (tbar)
 981                                (gtk-toolbar-set-space-size tbar 5)) toolbar)
 982     (gtk-toolbar-append-item toolbar
 983                              "Big" "Use big spaces" ""
 984                              (gtk-pixmap-new gtk-test-open-glyph nil)
 985                              (lambda (tbar)
 986                                (gtk-toolbar-set-space-size tbar 10)) toolbar)
 987
 988     (gtk-toolbar-append-space toolbar)
 989     (gtk-toolbar-append-item toolbar
 990                              "Enable" "Enable tooltips" ""
 991                              (gtk-pixmap-new gtk-test-open-glyph nil)
 992                              (lambda (tbar)
 993                                (gtk-toolbar-set-tooltips tbar t)) toolbar)
 994     (gtk-toolbar-append-item toolbar
 995                              "Disable" "Disable tooltips" ""
 996                              (gtk-pixmap-new gtk-test-open-glyph nil)
 997                              (lambda (tbar)
 998                                (gtk-toolbar-set-tooltips tbar nil)) toolbar)
 999
1000     (gtk-toolbar-append-space toolbar)
1001     (gtk-toolbar-append-item toolbar
1002                              "Borders" "Show borders" ""
1003                              (gtk-pixmap-new gtk-test-open-glyph nil)
1004                              (lambda (tbar)
1005                                (gtk-toolbar-set-button-relief tbar 'normal)) toolbar)
1006     (gtk-toolbar-append-item toolbar
1007                              "Borderless" "Hide borders" ""
1008                              (gtk-pixmap-new gtk-test-open-glyph nil)
1009                              (lambda (tbar)
1010                                (gtk-toolbar-set-button-relief tbar 'none)) toolbar)
1011
1012     (gtk-toolbar-append-space toolbar)
1013     (gtk-toolbar-append-item toolbar
1014                              "Empty" "Empty spaces" ""
1015                              (gtk-pixmap-new gtk-test-open-glyph nil)
1016                              (lambda (tbar)
1017                                (gtk-toolbar-set-space-style tbar 'empty)) toolbar)
1018     (gtk-toolbar-append-item toolbar
1019                              "Lines" "Lines in spaces" ""
1020                              (gtk-pixmap-new gtk-test-open-glyph nil)
1021                              (lambda (tbar)
1022                                (gtk-toolbar-set-space-style tbar 'line)) toolbar)
1023     (gtk-widget-show-all toolbar)
1024     toolbar))
1025
1026 (gtk-define-test
1027  "Toolbar" container toolbar nil
1028  (gtk-box-pack-start window (gtk-test-toolbar-create) t t 0))
1029
1030 \f
1031 ;;;; Text
1032 (gtk-define-test
1033  "Text" composite text nil
1034  (let ((text (gtk-text-new nil nil))
1035        (scrolled (gtk-scrolled-window-new nil nil))
1036        (bbox (gtk-hbutton-box-new))
1037        (button nil))
1038    (gtk-box-pack-start window scrolled t t 0)
1039    (gtk-box-pack-start window bbox nil nil 0)
1040    (gtk-widget-set-usize text 500 500)
1041    (gtk-container-add scrolled text)
1042
1043    (setq button (gtk-check-button-new-with-label "Editable"))
1044    (gtk-signal-connect button 'toggled
1045                        (lambda (button text)
1046                          (gtk-text-set-editable text (gtk-toggle-button-get-active button))) text)
1047    (gtk-container-add bbox button)
1048
1049    (setq button (gtk-check-button-new-with-label "Wrap words"))
1050    (gtk-signal-connect button 'toggled
1051                        (lambda (button text)
1052                          (gtk-text-set-word-wrap text (gtk-toggle-button-get-active button))) text)
1053    (gtk-container-add bbox button)
1054
1055    ;; put some default text in there.
1056    (gtk-widget-set-style text 'default)
1057    (let ((faces '(blue bold bold-italic gtk-test-face-large red text-cursor))
1058          (string nil))
1059      (mapc (lambda (face)
1060              (setq string (format "Sample text in the `%s' face\n" face))
1061              (gtk-text-insert text
1062                               (face-font face)
1063                               (face-foreground face)
1064                               (face-background face)
1065                               string (length string))) faces))
1066
1067
1068    ;; Tell the user their rights...
1069    (let ((file (locate-data-file "COPYING")))
1070      (gtk-text-freeze text)
1071      (save-excursion
1072        (set-buffer (get-buffer-create " *foo*"))
1073        (insert-file-contents file)
1074        (gtk-text-insert text nil nil nil (buffer-string) (point-max))
1075        (kill-buffer (current-buffer))))
1076      (gtk-text-thaw text)))
1077
1078 \f
1079 ;;;; handle box
1080 (gtk-define-test
1081  "Handle box" container handles nil
1082  (let ((handle nil)
1083        (hbox (gtk-hbox-new nil 0)))
1084
1085    (gtk-box-pack-start window (gtk-label-new "Above") nil nil 0)
1086    (gtk-box-pack-start window (gtk-hseparator-new) nil nil 0)
1087    (gtk-box-pack-start window hbox t t 0)
1088    (gtk-box-pack-start window (gtk-hseparator-new) nil nil 0)
1089    (gtk-box-pack-start window (gtk-label-new "Below") nil nil 0)
1090
1091    (setq handle (gtk-handle-box-new))
1092    (gtk-container-add handle (gtk-test-toolbar-create))
1093    (gtk-widget-show-all handle)
1094    (gtk-box-pack-start hbox handle nil nil 0)
1095    (gtk-signal-connect handle 'child_attached
1096                        (lambda (box child data)
1097                          (message "Child widget (%s) attached" child)))
1098    (gtk-signal-connect handle 'child_detached
1099                        (lambda (box child data)
1100                          (message "Child widget (%s) detached" child)))
1101
1102    (setq handle (gtk-handle-box-new))
1103    (gtk-container-add handle (gtk-label-new "Fooo!!!"))
1104    (gtk-box-pack-start hbox handle nil nil 0)
1105    (gtk-signal-connect handle 'child_attached
1106                        (lambda (box child data)
1107                          (message "Child widget (%s) attached" child)))
1108    (gtk-signal-connect handle 'child_detached
1109                        (lambda (box child data)
1110                          (message "Child widget (%s) detached" child)))))
1111
1112 \f
1113 ;;;; Menus
1114 (gtk-define-test
1115  "Menus" basic menus nil
1116  (let ((menubar (gtk-menu-bar-new))
1117        (item nil)
1118        (right-justify nil))
1119    (gtk-box-pack-start window menubar nil nil 0)
1120    (mapc (lambda (menudesc)
1121            (if (not menudesc)
1122                (setq right-justify t)
1123              (setq item (gtk-build-xemacs-menu menudesc))
1124              (gtk-widget-show item)
1125              (if right-justify
1126                  (gtk-menu-item-right-justify item))
1127              (gtk-menu-bar-append menubar item)))
1128          default-menubar)))
1129
1130 \f
1131 ;;;; Spinbutton
1132 (gtk-define-test
1133  "Spinbutton" composite spinbutton nil
1134  (let (frame vbox vbox2 hbox label spin adj spin2 button)
1135
1136    (gtk-container-set-border-width window 5)
1137
1138    (setq frame (gtk-frame-new "Not accelerated")
1139          hbox (gtk-hbox-new nil 0))
1140
1141    (gtk-box-pack-start window frame t t 0)
1142    (gtk-container-add frame hbox)
1143
1144    (setq vbox (gtk-vbox-new nil 0)
1145          label (gtk-label-new "Day:")
1146          adj (gtk-adjustment-new 1.0 1.0 31.0 1.0 5.0 0.0)
1147          spin (gtk-spin-button-new adj 0 0))
1148
1149    (gtk-misc-set-alignment label 0 0.5)
1150    (gtk-spin-button-set-wrap spin t)
1151    (gtk-spin-button-set-shadow-type spin 'out)
1152    (gtk-box-pack-start hbox vbox t t 5)
1153    (gtk-box-pack-start vbox label nil t 0)
1154    (gtk-box-pack-start vbox spin nil t 0)
1155
1156    (setq vbox (gtk-vbox-new nil 0)
1157          label (gtk-label-new "Month:")
1158          adj (gtk-adjustment-new 1.0 1.0 12.0 1.0 5.0 0.0)
1159          spin (gtk-spin-button-new adj 0 0))
1160    (gtk-misc-set-alignment label 0 0.5)
1161    (gtk-spin-button-set-wrap spin t)
1162    (gtk-spin-button-set-shadow-type spin 'out)
1163    (gtk-box-pack-start hbox vbox t t 5)
1164    (gtk-box-pack-start vbox label nil t 0)
1165    (gtk-box-pack-start vbox spin nil t 0)
1166
1167    (setq vbox (gtk-vbox-new nil 0)
1168          label (gtk-label-new "Year:")
1169          adj (gtk-adjustment-new 1998.0 0.0 2100.0 1.0 100.0 0.0)
1170          spin (gtk-spin-button-new adj 0 0))
1171    (gtk-misc-set-alignment label 0 0.5)
1172    (gtk-spin-button-set-wrap spin t)
1173    (gtk-spin-button-set-shadow-type spin 'out)
1174    (gtk-widget-set-usize spin 55 0)
1175    (gtk-box-pack-start hbox vbox t t 5)
1176    (gtk-box-pack-start vbox label nil t 0)
1177    (gtk-box-pack-start vbox spin nil t 0)
1178
1179    (setq frame (gtk-frame-new "Accelerated")
1180          vbox (gtk-vbox-new nil 0))
1181
1182    (gtk-box-pack-start window frame t t 0)
1183    (gtk-container-add frame vbox)
1184
1185    (setq hbox (gtk-hbox-new nil 0))
1186    (gtk-box-pack-start vbox hbox nil t 5)
1187
1188    (setq vbox2 (gtk-vbox-new nil 0)
1189          label (gtk-label-new "Value:")
1190          adj (gtk-adjustment-new 0.0 -10000.0 10000.0 0.5 100.0 0.0)
1191          spin (gtk-spin-button-new adj 1.0 2))
1192    (gtk-misc-set-alignment label 0 0.5)
1193    (gtk-spin-button-set-wrap spin t)
1194    (gtk-widget-set-usize spin 100 0)
1195    (gtk-box-pack-start vbox2 label nil t 0)
1196    (gtk-box-pack-start vbox2 spin nil t 0)
1197    (gtk-box-pack-start hbox vbox2 t t 0)
1198
1199    (setq vbox2 (gtk-vbox-new nil 0)
1200          label (gtk-label-new "Digits:")
1201          adj (gtk-adjustment-new 2 1 5 1 1 0)
1202          spin2 (gtk-spin-button-new adj 0 0))
1203    (gtk-misc-set-alignment label 0 0.5)
1204    (gtk-spin-button-set-wrap spin2 t)
1205    (gtk-widget-set-usize spin2 100 0)
1206    (gtk-box-pack-start vbox2 label nil t 0)
1207    (gtk-box-pack-start vbox2 spin2 nil t 0)
1208    (gtk-box-pack-start hbox vbox2 t t 0)
1209    (gtk-signal-connect adj 'value_changed
1210                        (lambda (adj spinners)
1211                          (gtk-spin-button-set-digits
1212                           (car spinners)
1213                           (gtk-spin-button-get-value-as-int (cdr spinners))))
1214                        (cons spin spin2))
1215
1216    (setq button (gtk-check-button-new-with-label "Snap to 0.5-ticks"))
1217    (gtk-signal-connect button 'clicked
1218                        (lambda (button spin)
1219                          (gtk-spin-button-set-snap-to-ticks
1220                           spin
1221                           (gtk-toggle-button-get-active button)))
1222                        spin)
1223    (gtk-box-pack-start vbox button t t 0)
1224    (gtk-toggle-button-set-active button t)
1225
1226    (setq button (gtk-check-button-new-with-label "Numeric only input mode"))
1227    (gtk-signal-connect button 'clicked
1228                        (lambda (button spin)
1229                          (gtk-spin-button-set-numeric
1230                           spin
1231                           (gtk-toggle-button-get-active button)))
1232                        spin)
1233    (gtk-box-pack-start vbox button t t 0)
1234    (gtk-toggle-button-set-active button t)
1235
1236    (setq label (gtk-label-new ""))
1237
1238    (setq hbox (gtk-hbutton-box-new))
1239    (gtk-box-pack-start vbox hbox nil t 5)
1240    (gtk-box-pack-start vbox label nil nil 5)
1241
1242    (setq button (gtk-button-new-with-label "Value as int"))
1243    (gtk-container-add hbox button)
1244    (gtk-signal-connect button 'clicked
1245                        (lambda (obj data)
1246                          (let ((spin (car data))
1247                                (label (cdr data)))
1248                            (gtk-label-set-text label
1249                                                (format "%d"
1250                                                        (gtk-spin-button-get-value-as-int spin)))))
1251                        (cons spin label))
1252
1253    (setq button (gtk-button-new-with-label "Value as float"))
1254    (gtk-container-add hbox button)
1255    (gtk-signal-connect button 'clicked
1256                        (lambda (obj data)
1257                          (let ((spin (car data))
1258                                (label (cdr data)))
1259                            (gtk-label-set-text label
1260                                                (format "%g"
1261                                                        (gtk-spin-button-get-value-as-float spin)))))
1262                        (cons spin label))))
1263
1264 \f
1265 ;;;; Reparenting
1266 (gtk-define-test
1267  "Reparenting" misc reparenting nil
1268  (let ((label (gtk-label-new "Hello World"))
1269        (frame-1 (gtk-frame-new "Frame 1"))
1270        (frame-2 (gtk-frame-new "Frame 2"))
1271        (button nil)
1272        (hbox (gtk-hbox-new nil 5))
1273        (vbox-1 nil)
1274        (vbox-2 nil)
1275        (reparent-func (lambda (button data)
1276                          (let ((label (car data))
1277                                (new-parent (cdr data)))
1278                            (gtk-widget-reparent label new-parent)))))
1279
1280    (gtk-box-pack-start window hbox t t 0)
1281    (gtk-box-pack-start hbox frame-1 t t 0)
1282    (gtk-box-pack-start hbox frame-2 t t 0)
1283
1284    (setq vbox-1 (gtk-vbox-new nil 0))
1285    (gtk-container-add frame-1 vbox-1)
1286    (setq vbox-2 (gtk-vbox-new nil 0))
1287    (gtk-container-add frame-2 vbox-2)
1288
1289    (setq button (gtk-button-new-with-label "switch"))
1290    (gtk-box-pack-start vbox-1 button nil nil 0)
1291    (gtk-signal-connect button 'clicked reparent-func (cons label vbox-2))
1292
1293    (setq button (gtk-button-new-with-label "switch"))
1294    (gtk-box-pack-start vbox-2 button nil nil 0)
1295    (gtk-signal-connect button 'clicked reparent-func (cons label vbox-1))
1296
1297    (gtk-box-pack-start vbox-2 label nil t 0)))
1298
1299
1300 ;;;; StatusBar
1301 (defvar statusbar-counter 1)
1302
1303 (gtk-define-test
1304  "Statusbar" composite statusbar nil
1305  (let ((bar (gtk-statusbar-new))
1306        (vbox nil)
1307        (button nil))
1308
1309    (setq vbox (gtk-vbox-new nil 0))
1310    (gtk-box-pack-start window vbox t t 0)
1311    (gtk-box-pack-end window bar t t 0)
1312
1313    (setq button (gtk-button-new-with-label "push something"))
1314    (gtk-box-pack-start-defaults vbox button)
1315    (gtk-signal-connect button 'clicked
1316                        (lambda (button bar)
1317                          (gtk-statusbar-push bar 1 (format "something %d" (incf statusbar-counter))))
1318                        bar)
1319
1320    (setq button (gtk-button-new-with-label "pop"))
1321    (gtk-box-pack-start-defaults vbox button)
1322    (gtk-signal-connect button 'clicked
1323                        (lambda (button bar)
1324                          (gtk-statusbar-pop bar 1)) bar)
1325
1326    (setq button (gtk-button-new-with-label "steal #4"))
1327    (gtk-box-pack-start-defaults vbox button)
1328    (gtk-signal-connect button 'clicked
1329                        (lambda (button bar)
1330                          (gtk-statusbar-remove bar 1 4)) bar)
1331
1332    (setq button (gtk-button-new-with-label "dump stack"))
1333    (gtk-box-pack-start-defaults vbox button)
1334    (gtk-widget-set-sensitive button nil)
1335
1336    (setq button (gtk-button-new-with-label "test contexts"))
1337    (gtk-box-pack-start-defaults vbox button)
1338    (gtk-signal-connect button 'clicked
1339                        (lambda (button bar)
1340                          (let ((contexts '("any context" "idle messages" "some text"
1341                                            "hit the mouse" "hit the mouse2")))
1342                            (message-box "%s"
1343                                         (mapconcat
1344                                          (lambda (ctx)
1345                                            (format "context=\"%s\", context_id=%d"
1346                                                    ctx (gtk-statusbar-get-context-id bar ctx)))
1347                                          contexts "\n")))) bar)))
1348
1349 \f
1350 ;;;; Columned List
1351 (gtk-define-test
1352  "Columnar List" composite clist nil
1353  (let ((titles '("auto resize" "not resizeable" "max width 100" "min width 50"
1354                  "hide column" "Title 5" "Title 6" "Title 7" "Title 8" "Title 9"
1355                  "Title 10" "Title 11"))
1356        hbox clist button separator scrolled-win check undo-button label)
1357
1358    (gtk-container-set-border-width window 0)
1359
1360    (setq scrolled-win (gtk-scrolled-window-new nil nil))
1361    (gtk-container-set-border-width scrolled-win 5)
1362    (gtk-scrolled-window-set-policy scrolled-win 'automatic 'automatic)
1363
1364    ;; create GtkCList here so we have a pointer to throw at the
1365    ;; button callbacks -- more is done with it later
1366    (setq clist (gtk-clist-new-with-titles (length titles) titles))
1367    (gtk-container-add scrolled-win clist)
1368
1369    ;; Make the columns live up to their titles.
1370    (gtk-clist-set-column-auto-resize clist 0 t)
1371    (gtk-clist-set-column-resizeable clist 1 nil)
1372    (gtk-clist-set-column-max-width clist 2 100)
1373    (gtk-clist-set-column-min-width clist 3 50)
1374
1375    (gtk-signal-connect clist 'click-column
1376                        (lambda (clist column data)
1377                          (cond
1378                           ((= column 4)
1379                            (gtk-clist-set-column-visibility clist column nil))
1380                           ((= column (gtk-clist-sort-column clist))
1381                            (gtk-clist-set-sort-type
1382                             clist (if (eq (gtk-clist-sort-type clist) 'ascending)
1383                                       'descending
1384                                     'ascending)))
1385                           (t
1386                            (gtk-clist-set-sort-column clist column)))
1387                          (gtk-clist-sort clist)))
1388
1389    ;; control buttons
1390    (setq hbox (gtk-hbox-new nil 5))
1391    (gtk-container-set-border-width hbox 5)
1392    (gtk-box-pack-start window hbox nil nil 0)
1393
1394    (setq button (gtk-button-new-with-label "Insert Row"))
1395    (gtk-box-pack-start hbox button t t 0)
1396    (gtk-signal-connect button 'clicked
1397                        (lambda (button clist)
1398                          (gtk-clist-append clist
1399                                            (list (format "CListRow %05d" (random 10000))
1400                                                  "Column 1"
1401                                                  "Column 2"
1402                                                  "Column 3"
1403                                                  "Column 4"
1404                                                  "Column 5"
1405                                                  "Column 6"
1406                                                  "Column 7"
1407                                                  "Column 8"
1408                                                  "Column 0"
1409                                                  "Column 10"
1410                                                  "Column 11"))) clist)
1411
1412    (setq button (gtk-button-new-with-label "Add 1,000 Rows with Pixmaps"))
1413    (gtk-box-pack-start hbox button t t 0)
1414    (gtk-signal-connect button 'clicked
1415                        (lambda (button clist)
1416                          (let ((row 0) i)
1417                            (gtk-clist-freeze clist)
1418                            (loop for i from 0 to 1000 do
1419                              (setq row
1420                                    (gtk-clist-append clist
1421                                                      (list
1422                                                       (format "CListRow %05d" (random 10000))
1423                                                       "Column 1"
1424                                                       "Column 2"
1425                                                       "Column 3"
1426                                                       "Column 4"
1427                                                       "Column 5"
1428                                                       "Column 6"
1429                                                       "Column 7"
1430                                                       "Column 8"
1431                                                       "Column 0"
1432                                                       "Column 10"
1433                                                       "Column 11")))
1434                              (gtk-clist-set-pixtext clist row 3 "gtk+" 5
1435                                                     gtk-test-mini-gtk-glyph
1436                                                     nil))
1437                            (gtk-clist-thaw clist))) clist)
1438
1439    (setq button (gtk-button-new-with-label "Add 10,000 Rows"))
1440    (gtk-box-pack-start hbox button t t 0)
1441    (gtk-signal-connect button 'clicked
1442                        (lambda (button clist)
1443                          (gtk-clist-freeze clist)
1444                          (loop for i from 0 to 10000 do
1445                            (gtk-clist-append clist
1446                                              (list
1447                                               (format "CListRow %05d" (random 10000))
1448                                               "Column 1"
1449                                               "Column 2"
1450                                               "Column 3"
1451                                               "Column 4"
1452                                               "Column 5"
1453                                               "Column 6"
1454                                               "Column 7"
1455                                               "Column 8"
1456                                               "Column 0"
1457                                               "Column 10"
1458                                               "Column 11")))
1459                          (gtk-clist-thaw clist)) clist)
1460
1461    ;; Second layer of buttons
1462    (setq hbox (gtk-hbox-new nil 5))
1463    (gtk-container-set-border-width hbox 5)
1464    (gtk-box-pack-start window hbox nil nil 0)
1465
1466    (setq button (gtk-button-new-with-label "Clear List"))
1467    (gtk-box-pack-start hbox button t t 0)
1468    (gtk-signal-connect button 'clicked (lambda (button clist)
1469                                          (gtk-clist-clear clist)) clist)
1470
1471    (setq button (gtk-button-new-with-label "Remove Selection"))
1472    (gtk-box-pack-start hbox button t t 0)
1473    (gtk-signal-connect button 'clicked (lambda (button clist)
1474                                          (error "Do not know how to do this yet.")))
1475    (gtk-widget-set-sensitive button nil)
1476
1477    (setq button (gtk-button-new-with-label "Undo Selection"))
1478    (gtk-box-pack-start hbox button t t 0)
1479    (gtk-signal-connect button 'clicked
1480                        (lambda (button clist) (gtk-clist-undo-selection clist)))
1481
1482    (setq button (gtk-button-new-with-label "Warning Test"))
1483    (gtk-box-pack-start hbox button t t 0)
1484    (gtk-signal-connect button 'clicked 'ignore)
1485    (gtk-widget-set-sensitive button nil)
1486
1487    ;; Third layer of buttons
1488    (setq hbox (gtk-hbox-new nil 5))
1489    (gtk-container-set-border-width hbox 5)
1490    (gtk-box-pack-start window hbox nil nil 0)
1491
1492    (setq button (gtk-check-button-new-with-label "Show Title Buttons"))
1493    (gtk-box-pack-start hbox button nil t 0)
1494    (gtk-signal-connect button 'clicked (lambda (button clist)
1495                                          (if (gtk-toggle-button-get-active button)
1496                                              (gtk-clist-column-titles-show clist)
1497                                            (gtk-clist-column-titles-hide clist))) clist)
1498    (gtk-toggle-button-set-active button t)
1499
1500    (setq button (gtk-check-button-new-with-label "Reorderable"))
1501    (gtk-box-pack-start hbox check nil t 0)
1502    (gtk-signal-connect button 'clicked (lambda (button clist)
1503                                          (gtk-clist-set-reorderable
1504                                           clist
1505                                           (gtk-toggle-button-get-active button))) clist)
1506    (gtk-toggle-button-set-active button t)
1507
1508    (setq label (gtk-label-new "Selection Mode :"))
1509    (gtk-box-pack-start hbox label nil t 0)
1510
1511    (gtk-box-pack-start hbox (build-option-menu
1512                              '(("Single"   .
1513                                 (lambda (item clist)
1514                                   (gtk-clist-set-selection-mode clist 'single)))
1515                                ("Browse"   .
1516                                 (lambda (item clist)
1517                                   (gtk-clist-set-selection-mode clist 'browse)))
1518                                ("Multiple" .
1519                                 (lambda (item clist)
1520                                   (gtk-clist-set-selection-mode clist 'multiple)))
1521                                ("Extended" .
1522                                 (lambda (item clist)
1523                                   (gtk-clist-set-selection-mode clist 'extended))))
1524                              3 clist) nil t 0)
1525
1526    ;; The rest of the clist configuration
1527    (gtk-box-pack-start window scrolled-win t t 0)
1528    (gtk-clist-set-row-height clist 18)
1529    (gtk-widget-set-usize clist -1 300)
1530
1531    (loop for i from 0 to 11 do
1532      (gtk-clist-set-column-width clist i 80))))
1533
1534 \f
1535 ;;;; Notebook
1536 (defun set-tab-label (notebook page selected-p)
1537   (if page
1538       (let (label label-box pixwid)
1539         (setq label-box (gtk-hbox-new nil 0))
1540         (setq pixwid (gtk-pixmap-new
1541                       (if selected-p gtk-test-open-glyph gtk-test-closed-glyph) nil))
1542         (gtk-box-pack-start label-box pixwid nil t 0)
1543         (gtk-misc-set-padding pixwid 3 1) ;
1544         (setq label (gtk-label-new
1545                      (format "Page %d" (1+ (gtk-notebook-page-num notebook page)))))
1546         (gtk-box-pack-start label-box label nil t 0)
1547         (gtk-widget-show-all label-box)
1548         (gtk-notebook-set-tab-label notebook page label-box))))
1549
1550 (defun page-switch (widget page page-num data)
1551   (let ((oldpage (gtk-notebook-get-current-page widget))
1552         (label nil)
1553         (label-box nil)
1554         (pixwid nil))
1555     (if (eq page-num oldpage)
1556         nil
1557       (set-tab-label widget (gtk-notebook-get-nth-page widget oldpage) nil)
1558       (set-tab-label widget (gtk-notebook-get-nth-page widget page-num) t))))
1559
1560 (defun create-pages (notebook start end)
1561   (let (child button label hbox vbox label-box menu-box pixwid i)
1562     (setq i start)
1563     (while (<= i end)
1564       (setq child (gtk-frame-new (format "Page %d" i)))
1565       (gtk-container-set-border-width child 10)
1566
1567       (setq vbox (gtk-vbox-new t 0))
1568       (gtk-container-set-border-width vbox 10)
1569       (gtk-container-add child vbox)
1570
1571       (setq hbox (gtk-hbox-new t 0))
1572       (gtk-box-pack-start vbox hbox nil t 5)
1573
1574       (setq button (gtk-check-button-new-with-label "Fill Tab"))
1575       (gtk-box-pack-start hbox button t t 5)
1576       (gtk-toggle-button-set-active button t)
1577       (gtk-signal-connect
1578        button 'toggled
1579        (lambda (button data)
1580          (let ((packing (gtk-notebook-query-tab-label-packing (car data) (cdr data))))
1581            (gtk-notebook-set-tab-label-packing (car data) (cdr data)
1582                                                (nth 0 packing)
1583                                                (gtk-toggle-button-get-active button)
1584                                                (nth 2 packing))))
1585        (cons notebook child))
1586
1587       (setq button (gtk-check-button-new-with-label "Expand Tab"))
1588       (gtk-box-pack-start hbox button t t 5)
1589       (gtk-signal-connect
1590        button 'toggled
1591        (lambda (button data)
1592          (let ((packing (gtk-notebook-query-tab-label-packing (car data) (cdr data))))
1593            (gtk-notebook-set-tab-label-packing (car data) (cdr data)
1594                                                (gtk-toggle-button-get-active button)
1595                                                (nth 1 packing) (nth 2 packing))))
1596        (cons notebook child))
1597
1598       (setq button (gtk-check-button-new-with-label "Pack End"))
1599       (gtk-box-pack-start hbox button t t 5)
1600       (gtk-signal-connect
1601        button 'toggled
1602        (lambda (button data)
1603          (let ((packing (gtk-notebook-query-tab-label-packing (car data) (cdr data))))
1604            (gtk-notebook-set-tab-label-packing (car data) (cdr data)
1605                                                (nth 0 packing) (nth 1 packing)
1606                                                (if (gtk-toggle-button-get-active button) 'end 'start))))
1607        (cons notebook child))
1608
1609       (setq button (gtk-button-new-with-label "Hide Page"))
1610       (gtk-box-pack-end vbox button nil nil 5)
1611       (gtk-signal-connect button 'clicked
1612                           (lambda (ignored child) (gtk-widget-hide child)) child)
1613
1614       (gtk-widget-show-all child)
1615
1616       (setq label-box (gtk-hbox-new nil 0))
1617       (setq pixwid (gtk-pixmap-new gtk-test-closed-glyph nil))
1618       (gtk-box-pack-start label-box pixwid nil t 0)
1619       (gtk-misc-set-padding pixwid 3 1);
1620       (setq label (gtk-label-new (format "Page %d" i)))
1621       (gtk-box-pack-start label-box label nil t 0)
1622       (gtk-widget-show-all label-box)
1623
1624       (setq menu-box (gtk-hbox-new nil 0))
1625       (setq pixwid (gtk-pixmap-new gtk-test-closed-glyph nil))
1626       (gtk-box-pack-start menu-box pixwid nil t 0)
1627       (gtk-misc-set-padding pixwid 3 1)
1628       (setq label (gtk-label-new (format "Page %d" i)))
1629       (gtk-box-pack-start menu-box label nil t 0)
1630       (gtk-widget-show-all menu-box)
1631       (gtk-notebook-append-page-menu notebook child label-box menu-box)
1632       (incf i))))
1633
1634 (gtk-define-test
1635  "Notebook" container notebook nil
1636  (let (box1 box2 button separator omenu transparent label sample-notebook)
1637    (gtk-container-set-border-width window 0)
1638
1639    (setq sample-notebook (gtk-notebook-new))
1640    (gtk-signal-connect sample-notebook 'switch_page 'page-switch)
1641    (gtk-notebook-set-tab-pos sample-notebook 'top)
1642    (gtk-box-pack-start window sample-notebook t t 0)
1643    (gtk-container-set-border-width sample-notebook 10)
1644
1645    (create-pages sample-notebook 1 5)
1646
1647    (setq separator (gtk-hseparator-new))
1648    (gtk-box-pack-start window separator nil t 10)
1649
1650    (setq box2 (gtk-hbox-new nil 5))
1651    (gtk-container-set-border-width box2 10)
1652    (gtk-box-pack-start window box2 nil t 0)
1653
1654    (setq button (gtk-check-button-new-with-label "popup menu"))
1655    (gtk-box-pack-start box2 button t nil 0)
1656    (gtk-signal-connect button 'clicked
1657                        (lambda (button notebook)
1658                          (if (gtk-toggle-button-get-active button)
1659                              (gtk-notebook-popup-enable notebook)
1660                            (gtk-notebook-popup-disable notebook))) sample-notebook)
1661
1662    (setq button (gtk-check-button-new-with-label "homogeneous tabs"))
1663    (gtk-box-pack-start box2 button t nil 0)
1664    (gtk-signal-connect button 'clicked
1665                        (lambda (button notebook)
1666                          (gtk-notebook-set-homogeneous-tabs
1667                           notebook
1668                           (gtk-toggle-button-get-active button))) sample-notebook)
1669
1670    (setq box2 (gtk-hbox-new nil 5))
1671    (gtk-container-set-border-width box2 10)
1672    (gtk-box-pack-start window box2 nil t 0)
1673
1674    (setq label (gtk-label-new "Notebook Style :"))
1675    (gtk-box-pack-start box2 label nil t 0)
1676
1677    (setq omenu (build-option-menu '(("Standard" .
1678                                      (lambda (b n)
1679                                        (gtk-notebook-set-show-tabs n t)
1680                                        (gtk-notebook-set-scrollable n nil)))
1681                                     ("No tabs"  .
1682                                      (lambda (b n)
1683                                        (gtk-notebook-set-show-tabs n nil)))
1684                                     ("Scrollable" .
1685                                      (lambda (b n)
1686                                        (gtk-notebook-set-show-tabs n t)
1687                                        (gtk-notebook-set-scrollable n t))))
1688                                   0
1689                                   sample-notebook))
1690    (gtk-box-pack-start box2 omenu nil t 0)
1691
1692    (setq button (gtk-button-new-with-label "Show all pages"))
1693    (gtk-box-pack-start box2 button nil t 0)
1694    (gtk-signal-connect
1695     button 'clicked (lambda (button notebook)
1696                       (mapc 'gtk-widget-show (gtk-container-children notebook)))
1697     sample-notebook)
1698
1699    (setq box2 (gtk-hbox-new t 10))
1700    (gtk-container-set-border-width box2 10)
1701    (gtk-box-pack-start window box2 nil t 0)
1702
1703    (setq button (gtk-button-new-with-label "prev"))
1704    (gtk-signal-connect button 'clicked
1705                        (lambda (button notebook)
1706                          (gtk-notebook-prev-page notebook)) sample-notebook)
1707    (gtk-box-pack-start box2 button t t 0)
1708
1709    (setq button (gtk-button-new-with-label "next"))
1710    (gtk-signal-connect button 'clicked
1711                        (lambda (button notebook)
1712                          (gtk-notebook-next-page notebook)) sample-notebook)
1713    (gtk-box-pack-start box2 button t t 0)
1714
1715    (setq button (gtk-button-new-with-label "rotate"))
1716    (gtk-signal-connect button 'clicked
1717                        (lambda (button notebook)
1718                          (gtk-notebook-set-tab-pos
1719                           notebook
1720                           (case (gtk-notebook-tab-pos notebook)
1721                            (top 'right)
1722                            (right 'bottom)
1723                            (bottom 'left)
1724                            (left 'top))))
1725                        sample-notebook)
1726
1727    (gtk-box-pack-start box2 button t t 0)))
1728
1729 \f
1730 ;;;; Glade interfaces
1731 (if (and (featurep 'glade)
1732          (file-exists-p (expand-file-name "gtk-test.glade" (gtk-test-directory))))
1733   (gtk-define-test
1734    "Glade Interface" misc libglade t
1735    (glade-init)
1736    (glade-xml-get-type)
1737    (let ((xml (glade-xml-new (expand-file-name "gtk-test.glade" (gtk-test-directory))
1738                              nil)))
1739      (setq window (glade-xml-get-widget xml "main_window"))
1740      (glade-xml-signal-autoconnect xml)))
1741   (fmakunbound 'gtk-test-libglade))
1742
1743 \f
1744 ;;;; CTree
1745 (defvar gtk-test-ctree-hash nil)
1746
1747 (defun gtk-test-ctree-expand-directory (ctree dir parent)
1748   (ignore-errors
1749     (let ((dirs (directory-files dir t nil nil 5))
1750           (files (directory-files dir t nil nil t))
1751           (node nil))
1752       (mapc (lambda (d)
1753               (if (or (string-match "/\\.$" d)
1754                       (string-match "/\\.\\.$" d))
1755                   nil
1756                 (setq node
1757                       (gtk-ctree-insert-node ctree parent nil
1758                                              (list (file-name-nondirectory d) "")
1759                                              0 nil nil nil nil nil t))
1760                 (puthash node d gtk-test-ctree-hash)
1761                 (gtk-ctree-insert-node ctree node nil
1762                                        (list "" "")
1763                                        0 nil nil nil nil nil nil)
1764                 (gtk-ctree-collapse ctree node)))
1765             dirs)
1766       (mapc (lambda (f)
1767               (gtk-ctree-insert-node ctree parent nil
1768                                      (list (file-name-nondirectory f)
1769                                            (user-login-name (nth 2 (file-attributes f))))
1770                                      0 nil nil nil nil t nil))
1771             files)
1772       (gtk-clist-columns-autosize ctree))))
1773
1774 (defun gtk-spin-button-new-with-label (label adjustment climb-rate digits)
1775   (let ((box (gtk-hbox-new nil 2))
1776         (spin (gtk-spin-button-new adjustment climb-rate digits))
1777         (lbl (gtk-label-new label)))
1778     (gtk-box-pack-start box lbl nil nil 0)
1779     (gtk-box-pack-start box spin t t 0)
1780     (cons box spin)))
1781
1782 (gtk-define-test
1783  "Columnar Tree" composite ctree nil
1784  (let ((scrolled (gtk-scrolled-window-new nil nil))
1785        (ctree (gtk-ctree-new-with-titles 2 0 '("File" "Owner")))
1786        (box (gtk-hbutton-box-new))
1787        (button nil))
1788    (setq gtk-test-ctree-hash (make-hash-table :test 'equal))
1789    (put scrolled 'child ctree)
1790    (put scrolled 'height 400)
1791    (put ctree 'line_style 'solid)
1792    (put ctree 'expander_style 'square)
1793
1794    (gtk-box-pack-start window scrolled t t 0)
1795    (gtk-box-pack-start window box nil nil 5)
1796
1797    (gtk-clist-freeze ctree)
1798    (gtk-test-ctree-expand-directory ctree "/" nil)
1799    (gtk-clist-thaw ctree)
1800
1801    (setq button (gtk-button-new-with-label "Expand all"))
1802    (put box 'child button)
1803    (gtk-signal-connect button 'clicked (lambda (button tree)
1804                                          (gtk-ctree-expand-recursive tree nil)) ctree)
1805
1806    (setq button (gtk-button-new-with-label "Collaps all"))
1807    (put box 'child button)
1808    (gtk-signal-connect button 'clicked (lambda (button tree)
1809                                          (gtk-ctree-collapse-recursive tree nil)) ctree)
1810
1811    (setq button (gtk-button-new-with-label "Change style"))
1812    (put box 'child button)
1813    (put button 'sensitive nil)
1814
1815    (setq box (gtk-hbox-new t 5))
1816    (gtk-box-pack-start window box nil nil 0)
1817
1818    (setq button (gtk-button-new-with-label "Select all"))
1819    (put box 'child button)
1820    (gtk-signal-connect button 'clicked (lambda (button tree)
1821                                          (gtk-ctree-select-recursive tree nil)) ctree)
1822
1823    (setq button (gtk-button-new-with-label "Unselect all"))
1824    (put box 'child button)
1825    (gtk-signal-connect button 'clicked (lambda (button tree)
1826                                          (gtk-ctree-unselect-recursive tree nil)) ctree)
1827
1828    (setq button (gtk-button-new-with-label "Remove all"))
1829    (put box 'child button)
1830    (gtk-signal-connect button 'clicked (lambda (button tree)
1831                                          (gtk-clist-freeze tree)
1832                                          (gtk-ctree-recurse
1833                                           tree nil
1834                                           (lambda (tree subnode data)
1835                                             (gtk-ctree-remove-node tree subnode)))
1836                                          (gtk-clist-thaw tree)) ctree)
1837
1838    (setq button (gtk-check-button-new-with-label "Reorderable"))
1839    (put box 'child button)
1840    (gtk-signal-connect button 'clicked (lambda (button tree)
1841                                          (put tree 'reorderable
1842                                               (gtk-toggle-button-get-active button))) ctree)
1843
1844    (setq box (gtk-hbox-new t 5))
1845    (gtk-box-pack-start window box nil nil 0)
1846
1847    (gtk-box-pack-start box (build-option-menu
1848                             '(("Dotted" . (lambda (item ctree) (put ctree 'line_style 'dotted)))
1849                               ("Solid"  . (lambda (item ctree) (put ctree 'line_style 'solid)))
1850                               ("Tabbed" . (lambda (item ctree) (put ctree 'line_style 'tabbed)))
1851                               ("None"   . (lambda (item ctree) (put ctree 'line_style 'none))))
1852                             0 ctree) nil t 0)
1853    (gtk-box-pack-start box (build-option-menu
1854                             '(("Square"   . (lambda (item ctree) (put ctree 'expander_style 'square)))
1855                               ("Triangle" . (lambda (item ctree) (put ctree 'expander_style 'triangle)))
1856                               ("Circular" . (lambda (item ctree) (put ctree 'expander_style 'circular)))
1857                               ("None"     . (lambda (item ctree) (put ctree 'expander_style 'none))))
1858                             0 ctree) nil t 0)
1859    (gtk-box-pack-start box (build-option-menu
1860                             '(("Left" . (lambda (item ctree)
1861                                           (gtk-clist-set-column-justification
1862                                            ctree (get ctree 'tree_column) 'left)))
1863                               ("Right" . (lambda (item ctree)
1864                                            (gtk-clist-set-column-justification
1865                                             ctree (get ctree 'tree_column) 'right))))
1866                             0 ctree) nil t 0)
1867    (gtk-box-pack-start box (build-option-menu
1868                             '(("Single"   .
1869                                (lambda (item clist)
1870                                  (gtk-clist-set-selection-mode clist 'single)))
1871                               ("Browse"   .
1872                                (lambda (item clist)
1873                                  (gtk-clist-set-selection-mode clist 'browse)))
1874                               ("Multiple" .
1875                                (lambda (item clist)
1876                                  (gtk-clist-set-selection-mode clist 'multiple)))
1877                               ("Extended" .
1878                                (lambda (item clist)
1879                                  (gtk-clist-set-selection-mode clist 'extended))))
1880                             3 ctree) nil t 0)
1881
1882    (setq box (gtk-hbox-new t 5))
1883    (gtk-box-pack-start window box nil nil 0)
1884
1885    (let (adj spinner)
1886      (setq adj (gtk-adjustment-new (get ctree 'indent) 0 999 1 5 5)
1887            spinner (gtk-spin-button-new-with-label "Indent: " adj 1 3))
1888      (put box 'child (car spinner))
1889      (gtk-signal-connect adj 'value-changed
1890                          (lambda (adj tree)
1891                            (put tree 'indent (truncate (gtk-adjustment-value adj)))) ctree)
1892
1893      (setq adj (gtk-adjustment-new (get ctree 'spacing) 0 999 1 5 5)
1894            spinner (gtk-spin-button-new-with-label "Spacing: " adj 1 3))
1895      (put box 'child (car spinner))
1896      (gtk-signal-connect adj 'value-changed
1897                          (lambda (adj tree)
1898                            (put tree 'spacing (truncate (gtk-adjustment-value adj)))) ctree)
1899
1900      (setq adj (gtk-adjustment-new (get ctree 'row_height) 0 999 1 5 5)
1901            spinner (gtk-spin-button-new-with-label "Row Height: " adj 1 3))
1902      (put box 'child (car spinner))
1903      (gtk-signal-connect adj 'value-changed
1904                          (lambda (adj tree)
1905                            (put tree 'row_height (truncate (gtk-adjustment-value adj)))) ctree)
1906
1907      (setq button (gtk-check-button-new-with-label "Show logical root"))
1908      (put box 'child button)
1909      (gtk-signal-connect button 'clicked
1910                          (lambda (button tree)
1911                            (put tree 'show_stub (gtk-toggle-button-get-active button))) ctree))
1912
1913    (gtk-signal-connect ctree 'tree-expand
1914                        (lambda (ctree node user-data)
1915                          (gtk-clist-freeze ctree)
1916                          (gtk-ctree-recurse
1917                           ctree node
1918                           (lambda (tree subnode user-data)
1919                             (if (not (equal subnode node))
1920                                 (gtk-ctree-remove-node tree subnode))))
1921                          (gtk-test-ctree-expand-directory ctree
1922                                                           (gethash node gtk-test-ctree-hash)
1923                                                           node)
1924                          (gtk-clist-thaw ctree)))))
1925
1926 \f
1927 ;;;; The main interface
1928
1929 (defun gtk-test-view-source (test)
1930   ;; View the source for this test in a XEmacs window.
1931   (if test
1932       (let ((path (expand-file-name "gtk-test.el" (gtk-test-directory))))
1933         (if (not (file-exists-p path))
1934             (error "Could not find source for gtk-test.el"))
1935         (find-file path)
1936         (widen)
1937         (goto-char (point-min))
1938         (if (not (re-search-forward (concat "(gtk-define-test[ \t\n]*\"" test "\"") nil t))
1939             (error "Could not find test: %s" test)
1940           (narrow-to-page)
1941           (goto-char (point-min))))))
1942
1943 (defvar gtk-test-selected-test nil)
1944
1945 (defun gtk-test ()
1946   (interactive)
1947   (let ((items nil)
1948         (box nil)
1949         (window nil)
1950         (category-trees nil)
1951         (tree nil)
1952         (pane nil)
1953         (scrolled nil)
1954         (src-button nil)
1955         (gc-button nil)
1956         (standalone-p (not (default-gtk-device)))
1957         (close-button nil))
1958     (gtk-init (list invocation-name))
1959     (if standalone-p
1960         (progn
1961           (gtk-object-destroy (gtk-adjustment-new 0 0 0 0 0 0))))
1962     (ignore-errors
1963       (or (fboundp 'gtk-test-gnome-pixmaps)
1964           (load-file (expand-file-name "gnome-test.el" (gtk-test-directory))))
1965       (or (fboundp 'gtk-test-color-combo)
1966           (load-file (expand-file-name "gtk-extra-test.el" (gtk-test-directory)))))
1967     (unwind-protect
1968         (progn
1969           (setq window (gtk-dialog-new)
1970                 box (gtk-vbox-new nil 5)
1971                 pane (gtk-hpaned-new)
1972                 scrolled (gtk-scrolled-window-new nil nil)
1973                 tree (gtk-tree-new)
1974                 src-button (gtk-button-new-with-label "View source")
1975                 gc-button (gtk-button-new-with-label "Garbage Collect")
1976                 close-button (gtk-button-new-with-label "Quit"))
1977           (gtk-window-set-title window
1978                                 (format "%s/GTK %d.%d.%d"
1979                                         (if (featurep 'infodock) "InfoDock" "XEmacs")
1980                                         emacs-major-version emacs-minor-version
1981                                         (or emacs-patch-level emacs-beta-version)))
1982
1983           (gtk-scrolled-window-set-policy scrolled 'automatic 'automatic)
1984           (gtk-scrolled-window-add-with-viewport scrolled tree)
1985           (gtk-widget-set-usize scrolled 200 600)
1986
1987           (gtk-box-pack-start (gtk-dialog-vbox window) pane t t 5)
1988           (gtk-paned-pack1 pane scrolled t nil)
1989           (gtk-paned-pack2 pane box t nil)
1990           (setq gtk-test-shell box)
1991           (gtk-widget-show-all box)
1992
1993           (gtk-container-add (gtk-dialog-action-area window) close-button)
1994           (gtk-container-add (gtk-dialog-action-area window) src-button)
1995           (gtk-container-add (gtk-dialog-action-area window) gc-button)
1996
1997           (gtk-signal-connect gc-button 'clicked
1998                               (lambda (obj data)
1999                                 (garbage-collect)))
2000           (gtk-signal-connect close-button 'clicked
2001                               (lambda (obj data)
2002                                 (gtk-widget-destroy data)) window)
2003           (gtk-signal-connect src-button 'clicked
2004                               (lambda (obj data)
2005                                 (gtk-test-view-source gtk-test-selected-test)))
2006
2007           ;; Try to be a nice person and sort the tests
2008           (setq gtk-defined-tests
2009                 (sort gtk-defined-tests
2010                       (lambda (a b)
2011                         (string-lessp (car a) (car b)))))
2012
2013           ;; This adds all of the buttons to the window.
2014           (mapcar (lambda (test)
2015                     (let* ((desc (nth 0 test))
2016                            (type (nth 1 test))
2017                            (func (nth 2 test))
2018                            (parent (cdr-safe (assoc type category-trees)))
2019                            (item (gtk-tree-item-new-with-label desc)))
2020                       (put item 'test-function func)
2021                       (put item 'test-description desc)
2022                       (put item 'test-type type)
2023                       (gtk-widget-show item)
2024                       (if (not parent)
2025                           (let ((subtree (gtk-tree-new)))
2026                             (setq parent (gtk-tree-item-new-with-label
2027                                           (or (cdr-safe (assoc type gtk-test-categories))
2028                                               (symbol-name type))))
2029                             (gtk-signal-connect subtree 'select-child
2030                                                 (lambda (tree widget data)
2031                                                   (setq gtk-test-selected-test (get widget 'test-description))
2032                                                   (funcall (get widget 'test-function))))
2033                             (gtk-tree-append tree parent)
2034                             (gtk-tree-item-set-subtree parent subtree)
2035                             (setq parent subtree)
2036                             (push (cons type parent) category-trees)))
2037                       (gtk-tree-append parent item)))
2038                   gtk-defined-tests)
2039           (gtk-widget-show-all window)
2040           (if standalone-p
2041               (progn
2042                 (gtk-signal-connect window 'destroy (lambda (w d)
2043                                                       (gtk-main-quit)))
2044                 (gtk-main)))))))