Mercurial > hg > xemacs-beta
annotate tests/gtk/gnome-test.el @ 5940:c608d4b0b75e cygwin64 tip
rescue lost branch from 64bit.backup
| author | Henry Thompson <ht@markup.co.uk> |
|---|---|
| date | Thu, 16 Dec 2021 18:48:58 +0000 |
| 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))) |