Mercurial > hg > xemacs-beta
comparison lisp/generic-widgets.el @ 462:0784d089fdc9 r21-2-46
Import from CVS: tag r21-2-46
| author | cvs |
|---|---|
| date | Mon, 13 Aug 2007 11:44:37 +0200 |
| parents | |
| children | 7039e6323819 |
comparison
equal
deleted
inserted
replaced
| 461:120ed4009e51 | 462:0784d089fdc9 |
|---|---|
| 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 ) |