Mercurial > hg > xemacs-beta
annotate tests/gtk/gnome-test.el @ 5407:7ba892d101ce
Convert remainder in "tests" with plain text GPLv2 to GPLv3
| author | Mats Lidell <matsl@xemacs.org> |
|---|---|
| date | Tue, 19 Oct 2010 22:33:36 +0200 |
| parents | ba07c880114a |
| children | b9167d522a9a |
| rev | line source |
|---|---|
|
4709
db7068430402
Add explicit GPL v2 or later notices to Bill Perry's code, where such notices
Jerry James <james@xemacs.org>
parents:
462
diff
changeset
|
1 ;; This file is part of XEmacs. |
|
5407
7ba892d101ce
Convert remainder in "tests" with plain text GPLv2 to GPLv3
Mats Lidell <matsl@xemacs.org>
parents:
5231
diff
changeset
|
2 |
|
7ba892d101ce
Convert remainder in "tests" with plain text GPLv2 to GPLv3
Mats Lidell <matsl@xemacs.org>
parents:
5231
diff
changeset
|
3 ;; XEmacs is free software: you can redistribute it and/or modify it |
|
4709
db7068430402
Add explicit GPL v2 or later notices to Bill Perry's code, where such notices
Jerry James <james@xemacs.org>
parents:
462
diff
changeset
|
4 ;; under the terms of the GNU General Public License as published by the |
|
5407
7ba892d101ce
Convert remainder in "tests" with plain text GPLv2 to GPLv3
Mats Lidell <matsl@xemacs.org>
parents:
5231
diff
changeset
|
5 ;; Free Software Foundation, either version 3 of the License, or (at your |
|
7ba892d101ce
Convert remainder in "tests" with plain text GPLv2 to GPLv3
Mats Lidell <matsl@xemacs.org>
parents:
5231
diff
changeset
|
6 ;; option) any later version. |
|
7ba892d101ce
Convert remainder in "tests" with plain text GPLv2 to GPLv3
Mats Lidell <matsl@xemacs.org>
parents:
5231
diff
changeset
|
7 |
|
4709
db7068430402
Add explicit GPL v2 or later notices to Bill Perry's code, where such notices
Jerry James <james@xemacs.org>
parents:
462
diff
changeset
|
8 ;; XEmacs is distributed in the hope that it will be useful, but WITHOUT |
|
db7068430402
Add explicit GPL v2 or later notices to Bill Perry's code, where such notices
Jerry James <james@xemacs.org>
parents:
462
diff
changeset
|
9 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or |
|
db7068430402
Add explicit GPL v2 or later notices to Bill Perry's code, where such notices
Jerry James <james@xemacs.org>
parents:
462
diff
changeset
|
10 ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License |
|
db7068430402
Add explicit GPL v2 or later notices to Bill Perry's code, where such notices
Jerry James <james@xemacs.org>
parents:
462
diff
changeset
|
11 ;; for more details. |
|
5407
7ba892d101ce
Convert remainder in "tests" with plain text GPLv2 to GPLv3
Mats Lidell <matsl@xemacs.org>
parents:
5231
diff
changeset
|
12 |
|
4709
db7068430402
Add explicit GPL v2 or later notices to Bill Perry's code, where such notices
Jerry James <james@xemacs.org>
parents:
462
diff
changeset
|
13 ;; You should have received a copy of the GNU General Public License |
|
5407
7ba892d101ce
Convert remainder in "tests" with plain text GPLv2 to GPLv3
Mats Lidell <matsl@xemacs.org>
parents:
5231
diff
changeset
|
14 ;; along with XEmacs. If not, see <http://www.gnu.org/licenses/>. |
|
4709
db7068430402
Add explicit GPL v2 or later notices to Bill Perry's code, where such notices
Jerry James <james@xemacs.org>
parents:
462
diff
changeset
|
15 |
| 462 | 16 (require 'gnome) |
| 17 | |
| 18 (gtk-define-test | |
| 19 "GNOME Stock Pixmaps" gnome gnome-pixmaps nil | |
| 20 (let ((hbox nil) | |
| 21 (vbox nil) | |
| 22 (widget nil) | |
| 23 (label nil) | |
| 24 (i 0)) | |
| 25 (mapc (lambda (b) | |
| 26 (if (= (% i 5) 0) | |
| 27 (progn | |
| 28 (setq hbox (gtk-hbutton-box-new)) | |
| 29 (gtk-box-set-spacing hbox 5) | |
| 30 (gtk-container-add window hbox))) | |
| 31 | |
| 32 (setq widget (gnome-stock-pixmap-widget-new window (car b)) | |
| 33 vbox (gtk-vbox-new t 0) | |
| 34 label (gtk-label-new (cdr b))) | |
| 35 (gtk-container-add hbox vbox) | |
| 36 (gtk-container-add vbox widget) | |
| 37 (gtk-container-add vbox label) | |
| 38 (gtk-widget-show-all vbox) | |
| 39 (setq i (1+ i))) | |
| 40 gnome-stock-pixmaps))) | |
| 41 | |
| 42 (gtk-define-test | |
| 43 "GNOME Stock Buttons" gnome gnome-buttons nil | |
| 44 (let ((hbbox nil) | |
| 45 (button nil) | |
| 46 (i 0)) | |
| 47 (mapc (lambda (b) | |
| 48 (setq button (gnome-stock-button (car b))) | |
| 49 (gtk-signal-connect button 'clicked (lambda (obj data) | |
| 50 (message "Stock GNOME Button: %s" data)) | |
| 51 (cdr b)) | |
| 52 (if (= (% i 3) 0) | |
| 53 (progn | |
| 54 (setq hbbox (gtk-hbutton-box-new)) | |
| 55 (gtk-button-box-set-spacing hbbox 5) | |
| 56 (gtk-container-add window hbbox))) | |
| 57 | |
| 58 (gtk-container-add hbbox button) | |
| 59 (gtk-widget-show button) | |
| 60 (setq i (1+ i))) | |
| 61 gnome-stock-buttons))) | |
| 62 | |
| 63 (gtk-define-test | |
| 64 "GNOME About" gnome gnome-about t | |
| 65 (setq window (gnome-about-new "XEmacs/GTK Test Application" | |
| 66 "1.0a" | |
| 67 "Copyright (C) 2000 Free Software Foundation" | |
| 68 '("William M. Perry <wmperry@gnu.org>" | |
| 69 "Ichabod Crane") | |
| 70 "This is a comment string... what wonderful commentary you have my dear!" | |
| 71 ""))) | |
| 72 | |
| 73 (gtk-define-test | |
| 74 "GNOME File Entry" gnome gnome-file-entry nil | |
| 75 (let ((button (gnome-file-entry-new nil "Test browse dialog..."))) | |
| 76 (gtk-container-add window button))) | |
| 77 | |
| 78 (gtk-define-test | |
| 79 "GNOME Color Picker" gnome gnome-color-picker nil | |
| 80 (let ((picker (gnome-color-picker-new)) | |
| 81 (hbox (gtk-hbox-new nil 0)) | |
| 82 (label (gtk-label-new "Please choose a color: "))) | |
| 83 | |
| 84 (gtk-box-pack-start hbox label nil nil 2) | |
| 85 (gtk-box-pack-start hbox picker t t 2) | |
| 86 (gtk-container-add window hbox) | |
| 87 (gtk-widget-show-all hbox))) | |
| 88 | |
| 89 (gtk-define-test | |
| 90 "GNOME Desktop Entry Editor" gnome gnome-dentry-edit nil | |
| 91 (let* ((notebook (gtk-notebook-new))) | |
| 92 (gnome-dentry-edit-new-notebook notebook) | |
| 93 (gtk-container-add window notebook))) | |
| 94 | |
| 95 (gtk-define-test | |
| 96 "GNOME Date Edit" gnome gnome-date-entry nil | |
| 97 (let ((date (gnome-date-edit-new 0 t t)) | |
| 98 button) | |
| 99 (gtk-box-pack-start window date t t 0) | |
| 100 | |
| 101 (setq button (gtk-check-button-new-with-label "Show time")) | |
| 102 (gtk-signal-connect button 'clicked | |
| 103 (lambda (button date) | |
| 104 (let ((flags (gnome-date-edit-get-flags date))) | |
| 105 (if (gtk-toggle-button-get-active button) | |
| 106 (push 'show-time flags) | |
| 107 (setq flags (delq 'show-time flags))) | |
| 108 (gnome-date-edit-set-flags date flags))) date) | |
| 109 (gtk-toggle-button-set-active button t) | |
| 110 (gtk-box-pack-start window button nil nil 0) | |
| 111 | |
| 112 (setq button (gtk-check-button-new-with-label "24 Hour format")) | |
| 113 (gtk-signal-connect button 'clicked | |
| 114 (lambda (button date) | |
| 115 (let ((flags (gnome-date-edit-get-flags date))) | |
| 116 (if (gtk-toggle-button-get-active button) | |
| 117 (push '24-hr flags) | |
| 118 (setq flags (delq '24-hr flags))) | |
| 119 (gnome-date-edit-set-flags date flags))) date) | |
| 120 (gtk-toggle-button-set-active button t) | |
| 121 (gtk-box-pack-start window button nil nil 0) | |
| 122 | |
| 123 (setq button (gtk-check-button-new-with-label "Week starts on monday")) | |
| 124 (gtk-signal-connect button 'clicked | |
| 125 (lambda (button date) | |
| 126 (let ((flags (gnome-date-edit-get-flags date))) | |
| 127 (if (gtk-toggle-button-get-active button) | |
| 128 (push 'week-starts-on-monday flags) | |
| 129 (setq flags (delq 'week-starts-on-monday flags))) | |
| 130 (gnome-date-edit-set-flags date flags))) date) | |
| 131 (gtk-toggle-button-set-active button t) | |
| 132 (gtk-box-pack-start window button nil nil 0))) | |
| 133 | |
| 134 (gtk-define-test | |
| 135 "GNOME Font Picker" gnome gnome-font-picker nil | |
| 136 (let ((hbox (gtk-hbox-new nil 5)) | |
| 137 (fp (gnome-font-picker-new)) | |
| 138 (label (gtk-label-new "Choose a font: ")) | |
| 139 (button nil)) | |
| 140 (gtk-box-pack-start hbox label t t 0) | |
| 141 (gtk-box-pack-start hbox fp nil nil 2) | |
| 142 (gnome-font-picker-set-title fp "Select a font...") | |
| 143 (gnome-font-picker-set-mode fp 'font-info) | |
| 144 (gtk-box-pack-start window hbox t t 0) | |
| 145 | |
| 146 (setq button (gtk-check-button-new-with-label "Use font in label")) | |
| 147 (gtk-signal-connect button 'clicked | |
| 148 (lambda (button fp) | |
| 149 (gnome-font-picker-fi-set-use-font-in-label | |
| 150 fp (gtk-toggle-button-get-active button) 14)) | |
| 151 fp) | |
| 152 (gtk-box-pack-start window button nil nil 0) | |
| 153 | |
| 154 (setq button (gtk-check-button-new-with-label "Show size")) | |
| 155 (gtk-signal-connect button 'clicked | |
| 156 (lambda (button fp) | |
| 157 (gnome-font-picker-fi-set-show-size | |
| 158 fp (gtk-toggle-button-get-active button))) | |
| 159 fp) | |
| 160 (gtk-box-pack-start window button nil nil 0))) | |
| 161 | |
| 162 (gtk-define-test | |
| 163 "GNOME Application" gnome gnome-app t | |
| 164 (setq window (gnome-app-new "XEmacs" "XEmacs/GNOME")) | |
| 165 (let ((menubar (gtk-menu-bar-new)) | |
| 166 (contents nil) | |
| 167 ;(toolbar-instance (specifier-instance top-toolbar)) | |
| 168 (toolbar nil) | |
| 169 (item nil) | |
| 170 (flushright nil)) | |
| 171 (mapc (lambda (node) | |
| 172 (if (not node) | |
| 173 (setq flushright t) | |
| 174 (setq item (gtk-build-xemacs-menu node)) | |
| 175 (gtk-widget-show item) | |
| 176 (if flushright (gtk-menu-item-right-justify item)) | |
| 177 (gtk-menu-append menubar item))) | |
| 178 current-menubar) | |
| 179 | |
| 180 (setq toolbar (gtk-toolbar-new 'horizontal 'both)) | |
| 181 (mapc (lambda (x) | |
| 182 (let ((button (gtk-button-new)) | |
| 183 (pixmap (gnome-stock-pixmap-widget-new toolbar x))) | |
| 184 (gtk-container-add button pixmap) | |
| 185 (gtk-toolbar-append-widget toolbar button (symbol-name x) nil))) | |
| 186 '(open save print cut copy paste undo spellcheck srchrpl mail help)) | |
| 187 | |
| 188 (setq contents (gtk-hbox-new nil 5)) | |
| 189 (let ((hbox contents) | |
| 190 (vbox (gtk-vbox-new nil 5)) | |
| 191 (frame nil) | |
| 192 (label nil)) | |
| 193 (gtk-box-pack-start hbox vbox nil nil 0) | |
| 194 | |
| 195 (setq frame (gtk-frame-new "Normal Label") | |
| 196 label (gtk-label-new "This is a Normal label")) | |
| 197 (gtk-container-add frame label) | |
| 198 (gtk-box-pack-start vbox frame nil nil 0) | |
| 199 | |
| 200 (setq frame (gtk-frame-new "Multi-line Label") | |
| 201 label (gtk-label-new "This is a multi-line label.\nSecond line\nThird line")) | |
| 202 (gtk-container-add frame label) | |
| 203 (gtk-box-pack-start vbox frame nil nil 0) | |
| 204 | |
| 205 (setq frame (gtk-frame-new "Left Justified Label") | |
| 206 label (gtk-label-new "This is a Left-Justified\nMulti-line label.\nThird line")) | |
| 207 (gtk-label-set-justify label 'left) | |
| 208 (gtk-container-add frame label) | |
| 209 (gtk-box-pack-start vbox frame nil nil 0) | |
| 210 | |
| 211 (setq frame (gtk-frame-new "Right Justified Label") | |
| 212 label (gtk-label-new "This is a Right-Justified\nMulti-line label.\nFourth line, (j/k)")) | |
| 213 (gtk-label-set-justify label 'right) | |
| 214 (gtk-container-add frame label) | |
| 215 (gtk-box-pack-start vbox frame nil nil 0) | |
| 216 | |
| 217 ;; Start a second row so that we don't make a ridiculously tall window | |
| 218 (setq vbox (gtk-vbox-new nil 5)) | |
| 219 (gtk-box-pack-start hbox vbox nil nil 0) | |
| 220 | |
| 221 (setq frame (gtk-frame-new "Line wrapped label") | |
| 222 label (gtk-label-new | |
| 223 (concat "This is an example of a line-wrapped label. It should not be taking " | |
| 224 "up the entire " ;;; big space to test spacing | |
| 225 "width allocated to it, but automatically wraps the words to fit. " | |
| 226 "The time has come, for all good men, to come to the aid of their party. " | |
| 227 "The sixth sheik's six sheep's sick.\n" | |
| 228 " It supports multiple paragraphs correctly, and correctly adds " | |
| 229 "many extra spaces. "))) | |
| 230 (gtk-label-set-line-wrap label t) | |
| 231 (gtk-container-add frame label) | |
| 232 (gtk-box-pack-start vbox frame nil nil 0) | |
| 233 | |
| 234 (setq frame (gtk-frame-new "Filled, wrapped label") | |
| 235 label (gtk-label-new | |
| 236 (concat | |
| 237 "This is an example of a line-wrapped, filled label. It should be taking " | |
| 238 "up the entire width allocated to it. Here is a seneance to prove " | |
| 239 "my point. Here is another sentence. " | |
| 240 "Here comes the sun, do de do de do.\n" | |
| 241 " This is a new paragraph.\n" | |
| 242 " This is another newer, longer, better paragraph. It is coming to an end, " | |
| 243 "unfortunately."))) | |
| 244 (gtk-label-set-justify label 'fill) | |
| 245 (gtk-label-set-line-wrap label t) | |
| 246 (gtk-container-add frame label) | |
| 247 (gtk-box-pack-start vbox frame nil nil 0) | |
| 248 | |
| 249 (setq frame (gtk-frame-new "Underlined label") | |
| 250 label (gtk-label-new (concat "This label is underlined!\n" | |
| 251 "This one is underlined in 日本語の入用quite a funky fashion"))) | |
| 252 (gtk-label-set-justify label 'left) | |
| 253 (gtk-label-set-pattern label "_________________________ _ _________ _ _____ _ __ __ ___ ____ _____") | |
| 254 (gtk-container-add frame label) | |
| 255 (gtk-box-pack-start vbox frame nil nil 0)) | |
| 256 | |
| 257 (gtk-widget-show-all toolbar) | |
| 258 (gtk-widget-show-all menubar) | |
| 259 (gtk-widget-show-all contents) | |
| 260 (gnome-app-set-menus window menubar) | |
| 261 (gnome-app-set-toolbar window toolbar) | |
| 262 (gnome-app-set-contents window contents))) |