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