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