|
462
|
1 ;;; generic-widgets.el --- Generic UI building
|
|
|
2
|
|
|
3 ;; Copyright (C) 2000 Free Software Foundation
|
|
|
4
|
|
|
5 ;; Maintainer: William Perry <wmperry@gnu.org>
|
|
|
6 ;; Keywords: extensions, dumped
|
|
|
7
|
|
|
8 ;; This file is part of XEmacs.
|
|
|
9
|
|
|
10 ;; XEmacs is free software; you can redistribute it and/or modify it
|
|
|
11 ;; under the terms of the GNU General Public License as published by
|
|
|
12 ;; the Free Software Foundation; either version 2, or (at your option)
|
|
|
13 ;; any later version.
|
|
|
14
|
|
|
15 ;; XEmacs is distributed in the hope that it will be useful, but
|
|
|
16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
|
18 ;; General Public License for more details.
|
|
|
19
|
|
|
20 ;; You should have received a copy of the GNU General Public License
|
|
|
21 ;; along with XEmacs; see the file COPYING. If not, write to the Free
|
|
|
22 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
|
|
|
23 ;; 02111-1307, USA.
|
|
|
24
|
|
|
25 ;;; Synched up with: Not in FSF
|
|
|
26
|
|
|
27 ;;; Commentary:
|
|
|
28
|
|
|
29 ;; This file is dumped with XEmacs.
|
|
|
30
|
|
|
31 (defun build-ui (ui)
|
|
|
32 (if (null ui)
|
|
|
33 (gtk-label-new "[empty]")
|
|
|
34 (let ((builder-func (intern-soft (format "build-ui::%s" (car ui))))
|
|
|
35 (widget nil))
|
|
|
36 (if (and builder-func (fboundp builder-func))
|
|
|
37 (progn
|
|
|
38 (setq widget (funcall builder-func ui))
|
|
|
39 (setcdr ui (plist-put (cdr ui) :x-internal-widget widget))
|
|
|
40 widget)
|
|
|
41 (error "Unknown ui element: %s" (car ui))))))
|
|
|
42
|
|
|
43 (defun show-ui (ui)
|
|
|
44 (let ((widget (plist-get (cdr ui) :x-internal-widget)))
|
|
|
45 (if (not widget)
|
|
|
46 (error "Attempting to show unrealized UI"))
|
|
|
47 (gtk-widget-show-all widget)
|
|
|
48 (gtk-signal-connect widget 'destroy
|
|
|
49 (lambda (widget ui)
|
|
|
50 (setcdr ui (plist-put (cdr ui) :x-internal-widget nil))) ui)))
|
|
|
51
|
|
|
52
|
|
|
53 (defun build-ui::window (spec)
|
|
|
54 "Create a top-level window for containing other widgets.
|
|
|
55 Properties:
|
|
|
56 :items list A list of child UI specs. Only the first is used.
|
|
|
57 :type toplevel/dialog/popup What type of window to create. Window managers
|
|
|
58 can (and usually do) treat each type differently.
|
|
|
59 "
|
|
|
60 (let ((plist (cdr spec))
|
|
|
61 (window nil)
|
|
|
62 (child nil))
|
|
|
63 (setq window (gtk-window-new (plist-get plist :type 'toplevel))
|
|
|
64 child (build-ui (car (plist-get plist :items))))
|
|
|
65 (gtk-container-add window child)
|
|
|
66 window))
|
|
|
67
|
|
|
68 (defun build-ui::box (spec)
|
|
|
69 "Create a box for containing other widgets.
|
|
|
70 Properties:
|
|
|
71 :items list A list of child UI specs.
|
|
|
72 :homogeneous t/nil Whether all children are the same width/height.
|
|
|
73 :spacing number Spacing between children.
|
|
|
74 :orientation horizontal/vertical How the widgets are stacked.
|
|
|
75
|
|
|
76 Additional properties on child widgets:
|
|
|
77 :expand t/nil Whether the new child is to be given extra space
|
|
|
78 allocated to box. The extra space will be divided
|
|
|
79 evenly between all children of box that use this
|
|
|
80 option.
|
|
|
81 :fill t/nil Whether space given to child by the expand option is
|
|
|
82 actually allocated to child, rather than just padding
|
|
|
83 it. This parameter has no effect if :expand is set to
|
|
|
84 nil. A child is always allocated the full height of a
|
|
|
85 horizontal box and the full width of a vertical box.
|
|
|
86 This option affects the other dimension.
|
|
|
87 :padding number Extra padding around this widget.
|
|
|
88 "
|
|
|
89 (let* ((plist (cdr spec))
|
|
|
90 (orientation (plist-get plist :orientation 'horizontal))
|
|
|
91 (children (plist-get plist :items))
|
|
|
92 (box nil)
|
|
|
93 (child-widget nil)
|
|
|
94 (child-plist nil))
|
|
|
95 (case orientation
|
|
|
96 (vertical (setq box (gtk-vbox-new (plist-get plist :homogeneous)
|
|
|
97 (plist-get plist :spacing))))
|
|
|
98 (horizontal (setq box (gtk-hbox-new (plist-get plist :homogeneous)
|
|
|
99 (plist-get plist :spacing))))
|
|
|
100 (otherwise (error "Unknown orientation for box: %s" orientation)))
|
|
|
101 (mapc
|
|
|
102 (lambda (child)
|
|
|
103 (setq child-plist (cdr child)
|
|
|
104 child-widget (build-ui child))
|
|
|
105 (if (listp child-widget)
|
|
|
106 (mapc (lambda (w)
|
|
|
107 (gtk-box-pack-start box w
|
|
|
108 (plist-get child-plist :expand)
|
|
|
109 (plist-get child-plist :fill)
|
|
|
110 (plist-get child-plist :padding))) child-widget)
|
|
|
111 (gtk-box-pack-start box child-widget
|
|
|
112 (plist-get child-plist :expand)
|
|
|
113 (plist-get child-plist :fill)
|
|
|
114 (plist-get child-plist :padding))))
|
|
|
115 children)
|
|
|
116 box))
|
|
|
117
|
|
|
118 (defun build-ui::tab-control (spec)
|
|
|
119 "Create a notebook widget.
|
|
|
120 Properties:
|
|
|
121 :items list A list of UI specs to use as notebook pages.
|
|
|
122 :homogeneous t/nil Whether all tabs are the same width.
|
|
|
123 :orientation top/bottom/left/right Position of tabs
|
|
|
124 :show-tabs t/nil Show the tabs on screen?
|
|
|
125 :scrollable t/nil Allow scrolling to view all tab widgets?
|
|
|
126
|
|
|
127 Additional properties on child widgets:
|
|
|
128 :tab-label ui A UI spec to use for the tab label.
|
|
|
129 "
|
|
|
130 (let* ((plist (cdr spec))
|
|
|
131 (notebook (gtk-notebook-new))
|
|
|
132 (children (plist-get plist :items))
|
|
|
133 (page-counter 1)
|
|
|
134 (label-widget nil)
|
|
|
135 (child-widget nil)
|
|
|
136 (child-plist nil))
|
|
|
137 ;; Set all the properties
|
|
|
138 (gtk-notebook-set-homogeneous-tabs notebook (plist-get plist :homogeneous))
|
|
|
139 (gtk-notebook-set-scrollable notebook (plist-get plist :scrollable t))
|
|
|
140 (gtk-notebook-set-show-tabs notebook (plist-get plist :show-tabs t))
|
|
|
141 (gtk-notebook-set-tab-pos notebook (plist-get plist :orientation 'top))
|
|
|
142
|
|
|
143 ;; Now fill in the tabs
|
|
|
144 (mapc
|
|
|
145 (lambda (child)
|
|
|
146 (setq child-plist (cdr child)
|
|
|
147 child-widget (build-ui child)
|
|
|
148 label-widget (build-ui (plist-get child-plist :tab-label
|
|
|
149 (list 'label :text (format "tab %d" page-counter))))
|
|
|
150 page-counter (1+ page-counter))
|
|
|
151 (gtk-notebook-append-page notebook child-widget label-widget))
|
|
|
152 children)
|
|
|
153 notebook))
|
|
|
154
|
|
|
155 (defun build-ui::text (spec)
|
|
|
156 "Create a multi-line text widget.
|
|
|
157 Properties:
|
|
|
158 :editable t/nil Whether the user can change the contents
|
|
|
159 :word-wrap t/nil Automatic word wrapping?
|
|
|
160 :line-wrap t/nil Automatic line wrapping?
|
|
|
161 :text string Initial contents of the widget
|
|
|
162 :file filename File for initial contents (takes precedence over :text)
|
|
|
163 :face facename XEmacs face to use in the widget.
|
|
|
164 "
|
|
|
165 (let* ((plist (cdr spec))
|
|
|
166 (text (gtk-text-new nil nil))
|
|
|
167 (face (plist-get plist :face 'default))
|
|
|
168 (info (plist-get plist :text))
|
|
|
169 (file (plist-get plist :file)))
|
|
|
170 (gtk-text-set-editable text (plist-get plist :editable))
|
|
|
171 (gtk-text-set-word-wrap text (plist-get plist :word-wrap))
|
|
|
172 (gtk-text-set-line-wrap text (plist-get plist :line-wrap))
|
|
|
173 (gtk-widget-set-style text 'default)
|
|
|
174
|
|
|
175 ;; Possible convert the file portion
|
|
|
176 (if (and file (not (stringp file)))
|
|
|
177 (setq file (eval file)))
|
|
|
178
|
|
|
179 (if (and info (not (stringp info)))
|
|
|
180 (setq info (eval info)))
|
|
|
181
|
|
|
182 (if (and file (file-exists-p file) (file-readable-p file))
|
|
|
183 (save-excursion
|
|
|
184 (set-buffer (get-buffer-create " *improbable buffer name*"))
|
|
|
185 (insert-file-contents file)
|
|
|
186 (setq info (buffer-string))))
|
|
|
187
|
|
|
188 (gtk-text-insert text
|
|
|
189 (face-font face)
|
|
|
190 (face-foreground face)
|
|
|
191 (face-background face)
|
|
|
192 info (length info))
|
|
|
193 text))
|
|
|
194
|
|
|
195 (defun build-ui::label (spec)
|
|
|
196 "Create a label widget.
|
|
|
197 Properties:
|
|
|
198 :text string Text inside the label
|
|
|
199 :face facename XEmacs face to use in the widget.
|
|
|
200 :justification right/left/center How to justify the text.
|
|
|
201 "
|
|
|
202 (let* ((plist (cdr spec))
|
|
|
203 (label (gtk-label-new (plist-get plist :text))))
|
|
|
204 (gtk-label-set-line-wrap label t)
|
|
|
205 (gtk-label-set-justify label (plist-get plist :justification))
|
|
|
206 (gtk-widget-set-style label (plist-get plist :face 'default))
|
|
|
207 label))
|
|
|
208
|
|
|
209 (defun build-ui::pixmap (spec)
|
|
|
210 "Create a multi-line text widget.
|
|
|
211 Properties:
|
|
|
212 :text string Text inside the label
|
|
|
213 :face facename XEmacs face to use in the widget.
|
|
|
214 :justification right/left/center How to justify the text.
|
|
|
215 "
|
|
|
216 (let* ((plist (cdr spec))
|
|
|
217 (label (gtk-label-new (plist-get plist :text))))
|
|
|
218 (gtk-label-set-line-wrap label t)
|
|
|
219 (gtk-label-set-justify label (plist-get plist :justification))
|
|
|
220 (gtk-widget-set-style label (plist-get plist :face 'default))
|
|
|
221 label))
|
|
|
222
|
|
|
223 (defun build-ui::radio-group (spec)
|
|
|
224 "A convenience when specifying a group of radio buttons."
|
|
|
225 (let ((build-ui::radio-group nil))
|
|
|
226 (mapcar 'build-ui (plist-get (cdr spec) :items))))
|
|
|
227
|
|
|
228 (defun build-ui::button (spec)
|
|
|
229 "Create a button widget.
|
|
|
230 Properties:
|
|
|
231 :type radio/check/toggle/nil What type of button to create.
|
|
|
232 :text string Text in the button.
|
|
|
233 :glyph glyph Image in the button.
|
|
|
234 :label ui A UI spec to use for the label.
|
|
|
235 :relief normal/half/none How to draw button edges.
|
|
|
236
|
|
|
237 NOTE: Radio buttons must be in a radio-group object for them to work.
|
|
|
238 "
|
|
|
239 (let ((plist (cdr spec))
|
|
|
240 (button nil)
|
|
|
241 (button-type (plist-get plist :type 'normal))
|
|
|
242 (label nil))
|
|
|
243 (case button-type
|
|
|
244 (radio
|
|
|
245 (if (not (boundp 'build-ui::radio-group))
|
|
|
246 (error "Attempt to use a radio button outside a radio-group"))
|
|
|
247 (setq button (gtk-radio-button-new build-ui::radio-group)
|
|
|
248 build-ui::radio-group (gtk-radio-button-group button)))
|
|
|
249 (check
|
|
|
250 (setq button (gtk-check-button-new)))
|
|
|
251 (toggle
|
|
|
252 (setq button (gtk-toggle-button-new)))
|
|
|
253 (normal
|
|
|
254 (setq button (gtk-button-new)))
|
|
|
255 (otherwise
|
|
|
256 (error "Unknown button type: %s" button-type)))
|
|
|
257 (gtk-container-add
|
|
|
258 button
|
|
|
259 (build-ui (plist-get plist :label
|
|
|
260 (list 'label :text
|
|
|
261 (plist-get plist
|
|
|
262 :text (format "%s button" button-type))))))
|
|
|
263 button))
|
|
|
264
|
|
|
265 (defun build-ui::progress-gauge (spec)
|
|
|
266 "Create a progress meter.
|
|
|
267 Properties:
|
|
|
268 :orientation left-to-right/right-to-left/top-to-bottom/bottom-to-top
|
|
|
269 :type discrete/continuous
|
|
|
270
|
|
|
271 "
|
|
|
272 (let ((plist (cdr spec))
|
|
|
273 (gauge (gtk-progress-bar-new)))
|
|
|
274 (gtk-progress-bar-set-orientation gauge (plist-get plist :orientation 'left-to-right))
|
|
|
275 (gtk-progress-bar-set-bar-style gauge (plist-get plist :type 'continuous))
|
|
|
276 gauge))
|
|
|
277
|
|
|
278 (provide 'generic-widgets)
|
|
|
279
|
|
|
280 (when (featurep 'gtk) ; just loading this file should be OK
|
|
|
281 (gtk-widget-show-all
|
|
|
282 (build-ui
|
|
|
283 '(window :type dialog
|
|
|
284 :items ((tab-control
|
|
|
285 :homogeneous t
|
|
|
286 :orientation bottom
|
|
|
287 :items ((box :orientation vertical
|
|
|
288 :tab-label (label :text "vertical")
|
|
|
289 :items ((label :text "Vertical")
|
|
|
290 (progress-gauge)
|
|
|
291 (label :text "Box stacking")))
|
|
|
292 (box :orientation horizontal
|
|
|
293 :spacing 10
|
|
|
294 :items ((label :text "Horizontal box")
|
|
|
295 (label :text "stacking")))
|
|
|
296
|
|
|
297 (box :orientation vertical
|
|
|
298 :items
|
|
|
299 ((radio-group
|
|
|
300 :items ((button :type radio
|
|
|
301 :expand nil
|
|
|
302 :fill nil
|
|
|
303 :text "Item 1")
|
|
|
304 (button :type radio
|
|
|
305 :expand nil
|
|
|
306 :fill nil
|
|
|
307 :text "Item 2")
|
|
|
308 (button :type radio
|
|
|
309 :expand nil
|
|
|
310 :fill nil
|
|
|
311 :text "Item 3")
|
|
|
312 (button :type radio
|
|
|
313 :expand nil
|
|
|
314 :fill nil)))))
|
|
|
315 (box :orientation vertical
|
|
|
316 :items ((button :type check
|
|
|
317 :text "Item 1")
|
|
|
318 (button :type check
|
|
|
319 :text "Item 2")
|
|
|
320 (button :type normal
|
|
|
321 :text "Item 3")
|
|
|
322 (button :type toggle)))
|
|
|
323 (text :editable t
|
|
|
324 :word-wrap t
|
|
|
325 :file (locate-data-file "COPYING"))
|
|
|
326 (text :editable t
|
|
|
327 :face display-time-mail-balloon-enhance-face
|
|
|
328 :word-wrap t
|
|
|
329 :text "Text with a face on it")))))))
|
|
|
330 )
|
