Mercurial > hg > xemacs-beta
annotate tests/gtk/gtk-test.el @ 5228:5efbd1253905
Remove all support for InfoDock.
src/ChangeLog addition:
2010-06-02 Aidan Kehoe <kehoea@parhasard.net>
* lread.c (vars_of_lread):
* emacs.c:
(shut_down_emacs, vars_of_emacs, complex_vars_of_emacs):
* device-x.c (get_device_from_display)
(have_xemacs_resources_in_xrdb):
* device-gtk.c (Fgtk_init):
* config.h.in:
Remove all checks for InfoDock.
lisp/ChangeLog addition:
2010-06-02 Aidan Kehoe <kehoea@parhasard.net>
* version.el:
(emacs-version):
* startup.el (command-line):
* simple.el (display-warning, emacs-name):
* packages.el (packages-package-hierarchy-directory-names):
* loadup.el (Dumping):
* dumped-lisp.el (preloaded-file-list):
Remove all InfoDock-specific code.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Mon, 07 Jun 2010 18:42:10 +0100 |
| parents | 0784d089fdc9 |
| children | 308d34e9f07d |
| 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 | |
| 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" | |
|
5228
5efbd1253905
Remove all support for InfoDock.
Aidan Kehoe <kehoea@parhasard.net>
parents:
462
diff
changeset
|
1979 "XEmacs" |
| 462 | 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))))))) |