Mercurial > hg > xemacs-beta
annotate tests/gtk/gtk-test.el @ 5402:308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
| author | Mats Lidell <matsl@xemacs.org> |
|---|---|
| date | Thu, 14 Oct 2010 17:15:20 +0200 |
| parents | 5efbd1253905 |
| children |
| rev | line source |
|---|---|
| 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 | |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5228
diff
changeset
|
10 ;; XEmacs is free software: you can redistribute it and/or modify it |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5228
diff
changeset
|
11 ;; under the terms of the GNU General Public License as published by the |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5228
diff
changeset
|
12 ;; Free Software Foundation, either version 3 of the License, or (at your |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5228
diff
changeset
|
13 ;; option) any later version. |
| 462 | 14 |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5228
diff
changeset
|
15 ;; XEmacs is distributed in the hope that it will be useful, but WITHOUT |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5228
diff
changeset
|
16 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5228
diff
changeset
|
17 ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5228
diff
changeset
|
18 ;; for more details. |
| 462 | 19 |
| 20 ;; You should have received a copy of the GNU General Public License | |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5228
diff
changeset
|
21 ;; along with XEmacs. If not, see <http://www.gnu.org/licenses/>. |
| 462 | 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 | |
| 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 | |
| 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 | |
| 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 | |
| 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 | |
| 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 | |
| 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 | |
| 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 | |
| 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 | |
| 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 | |
| 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 | |
| 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 | |
| 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 | |
| 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 | |
| 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 | |
| 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 | |
| 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 | |
| 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 | |
| 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 | |
| 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 | |
| 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 | |
| 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 | |
| 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 | |
| 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 | |
| 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 | |
| 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 | |
| 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 | |
| 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" | |
|
5228
5efbd1253905
Remove all support for InfoDock.
Aidan Kehoe <kehoea@parhasard.net>
parents:
462
diff
changeset
|
1977 "XEmacs" |
| 462 | 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))))))) |