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