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