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