Mercurial > hg > xemacs-beta

comparison tests/gtk/gnome-test.el @ 462:0784d089fdc9 r21-2-46

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