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