Mercurial > hg > xemacs-beta

view lisp/generic-widgets.el @ 613:023b83f4e54b

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
[xemacs-hg @ 2001-06-10 10:42:16 by ben] ------ signal-code changes ------ data.c, device-tty.c, emacs.c, floatfns.c, linuxplay.c, nas.c, process-unix.c, signal.c, sunplay.c, sysdep.c, syssignal.h: use EMACS_SIGNAL everywhere instead of playing preprocessing games with signal(). s\windowsnt.h, s\mingw32.h, syssignal.h: Remove mswindows signal code from s+m headers and move to syssignal.h as one of the five ways of signal handling, instead of playing preprocessing games. fileio.c, sysdep.c: Rename sys_do_signal to qxe_reliable_signal. signal.c, process-unix.c, profile.c: Create set_timeout_signal(); use instead of just EMACS_SIGNAL to establish a signal handler on a timeout signal; this does special things under Cygwin. nt.c: Eliminate term_ntproc(), which is blank; used as a SIGABRT handler, which was wrong anyway. nt.c, win32.c: Move signal code from nt.c to win32.c, since Cygwin needs it too when dealing with timeout signals. s\cygwin32.h: Define CYGWIN_BROKEN_SIGNALS. ------ other changes ------ s\mingw32.h: Fix problems with NOT_C_CODE being in the wrong place and excluding defines needed when building Makefile.in.in. filelock.c, mule-canna.c, mule-ccl.c, mule-ccl.h, ralloc.c, unexalpha.c, unexapollo.c, unexcw.c, unexelfsgi.c, unexnt.c, unexsni.c, s\aix3-1.h, s\bsd4-1.h, s\bsd4-2.h, s\bsd4-3.h, s\cxux.h, s\cygwin32.h, s\dgux.h, s\dgux5-4r2.h, s\dgux5-4r3.h, s\dgux5-4r4.h, s\ewsux5r4.h, s\gnu.h, s\hpux.h, s\iris3-5.h, s\iris3-6.h, s\irix3-3.h, s\linux.h, s\mingw32.h, s\newsos5.h, s\nextstep.h, s\ptx.h, s\riscix1-1.h, s\riscix1-2.h, s\rtu.h, s\sco4.h, s\sco5.h, s\template.h, s\ultrix.h, s\umax.h, s\umips.h, s\unipl5-0.h, s\unipl5-2.h, s\usg5-0.h, s\usg5-2-2.h, s\usg5-2.h, s\usg5-3.h, s\usg5-4.h, s\windowsnt.h, s\xenix.h: Rename 'GNU Emacs' to XEmacs in the copyright and comments. nas.c: Stylistic cleanup. Avoid preprocessing games with names such as play_sound_file. ------ signal-code changes ------ data.c, device-tty.c, emacs.c, floatfns.c, linuxplay.c, nas.c, process-unix.c, signal.c, sunplay.c, sysdep.c, syssignal.h: use EMACS_SIGNAL everywhere instead of playing preprocessing games with signal(). s\windowsnt.h, s\mingw32.h, syssignal.h: Remove mswindows signal code from s+m headers and move to syssignal.h as one of the five ways of signal handling, instead of playing preprocessing games. fileio.c, sysdep.c: Rename sys_do_signal to qxe_reliable_signal. signal.c, process-unix.c, profile.c: Create set_timeout_signal(); use instead of just EMACS_SIGNAL to establish a signal handler on a timeout signal; this does special things under Cygwin. nt.c: Eliminate term_ntproc(), which is blank; used as a SIGABRT handler, which was wrong anyway. nt.c, win32.c: Move signal code from nt.c to win32.c, since Cygwin needs it too when dealing with timeout signals. s\cygwin32.h: Define CYGWIN_BROKEN_SIGNALS. ------ other changes ------ s\mingw32.h: Fix problems with NOT_C_CODE being in the wrong place and excluding defines needed when building Makefile.in.in. filelock.c, mule-canna.c, mule-ccl.c, mule-ccl.h, ralloc.c, unexalpha.c, unexapollo.c, unexcw.c, unexelfsgi.c, unexnt.c, unexsni.c, s\aix3-1.h, s\bsd4-1.h, s\bsd4-2.h, s\bsd4-3.h, s\cxux.h, s\cygwin32.h, s\dgux.h, s\dgux5-4r2.h, s\dgux5-4r3.h, s\dgux5-4r4.h, s\ewsux5r4.h, s\gnu.h, s\hpux.h, s\iris3-5.h, s\iris3-6.h, s\irix3-3.h, s\linux.h, s\mingw32.h, s\newsos5.h, s\nextstep.h, s\ptx.h, s\riscix1-1.h, s\riscix1-2.h, s\rtu.h, s\sco4.h, s\sco5.h, s\template.h, s\ultrix.h, s\umax.h, s\umips.h, s\unipl5-0.h, s\unipl5-2.h, s\usg5-0.h, s\usg5-2-2.h, s\usg5-2.h, s\usg5-3.h, s\usg5-4.h, s\windowsnt.h, s\xenix.h: Rename 'GNU Emacs' to XEmacs in the copyright and comments. nas.c: Stylistic cleanup. Avoid preprocessing games with names such as play_sound_file. xemacs-faq.texi: Update sections on Windows and MacOS availability. alist.el, apropos.el, autoload.el, bytecomp.el, cl-compat.el, cl-extra.el, cl-macs.el, cl-seq.el, cl.el, cmdloop.el, cus-edit.el, derived.el, gpm.el, itimer.el, lisp-mode.el, shadow.el, version.el, wid-browse.el: Rename 'GNU Emacs' to XEmacs in the copyright. Fix other references to GNU Emacs that should be XEmacs or just Emacs. files.el: Fix warning. simple.el: transpose-line-up/down will now move the region up or down by a line if active. cvtmail.c, fakemail.c, gnuserv.c, gnuserv.h, gnuslib.c, make-msgfile.c, make-path.c, pop.c, pop.h, profile.c, tcp.c: Rename 'GNU Emacs' to XEmacs in the copyright. Fix comments in similar ways. digest-doc.c, sorted-doc.c: Fix program and author name to reflect XEmacs.
author ben
date Sun, 10 Jun 2001 10:42:39 +0000
parents 7039e6323819
children 308d34e9f07d
line wrap: on
line source

;;; generic-widgets.el --- Generic UI building

;; Copyright (C) 2000 Free Software Foundation

;; Maintainer: William Perry <wmperry@gnu.org>
;; Keywords: extensions, dumped

;; This file is part of XEmacs.

;; XEmacs is free software; you can redistribute it and/or modify it
;; under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; XEmacs is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with XEmacs; see the file COPYING.  If not, write to the Free
;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
;; 02111-1307, USA.

;;; Synched up with: Not in FSF

;;; Commentary:

;; This file is dumped with XEmacs.

(globally-declare-fboundp
 '(gtk-label-new
   gtk-widget-show-all gtk-signal-connect
   gtk-window-new gtk-container-add gtk-vbox-new gtk-hbox-new
   gtk-box-pack-start gtk-notebook-new
   gtk-notebook-set-homogeneous-tabs gtk-notebook-set-scrollable
   gtk-notebook-set-show-tabs gtk-notebook-set-tab-pos
   gtk-notebook-append-page gtk-text-new gtk-text-set-editable
   gtk-text-set-word-wrap gtk-text-set-line-wrap
   gtk-widget-set-style gtk-text-insert gtk-label-set-line-wrap
   gtk-label-set-justify gtk-radio-button-new
   gtk-radio-button-group gtk-check-button-new
   gtk-toggle-button-new gtk-button-new gtk-progress-bar-new
   gtk-progress-bar-set-orientation gtk-progress-bar-set-bar-style))

(defun build-ui (ui)
  (if (null ui)
      (gtk-label-new "[empty]")
    (let ((builder-func (intern-soft (format "build-ui::%s" (car ui))))
	  (widget nil))
      (if (and builder-func (fboundp builder-func))
	  (progn
	    (setq widget (funcall builder-func ui))
	    (setcdr ui (plist-put (cdr ui) :x-internal-widget widget))
	    widget)
	(error "Unknown ui element: %s" (car ui))))))

(defun show-ui (ui)
  (let ((widget (plist-get (cdr ui) :x-internal-widget)))
    (if (not widget)
	(error "Attempting to show unrealized UI"))
    (gtk-widget-show-all widget)
    (gtk-signal-connect widget 'destroy
			(lambda (widget ui)
			  (setcdr ui (plist-put (cdr ui) :x-internal-widget nil))) ui)))


(defun build-ui::window (spec)
  "Create a top-level window for containing other widgets.
Properties:
:items		list			A list of child UI specs.  Only the first is used.
:type		toplevel/dialog/popup	What type of window to create.  Window managers
					can (and usually do) treat each type differently.
"
  (let ((plist (cdr spec))
	(window nil)
	(child nil))
    (setq window (gtk-window-new (plist-get plist :type 'toplevel))
	  child (build-ui (car (plist-get plist :items))))
    (gtk-container-add window child)
    window))

(defun build-ui::box (spec)
  "Create a box for containing other widgets.
Properties:
:items		list			A list of child UI specs.
:homogeneous	t/nil			Whether all children are the same width/height.
:spacing	number			Spacing between children.
:orientation	horizontal/vertical	How the widgets are stacked.

Additional properties on child widgets:
:expand		t/nil		Whether the new child is to be given extra space
				allocated to box. The extra space will be divided
				evenly between all children of box that use this
				option.
:fill		t/nil		Whether space given to child by the expand option is
				actually allocated to child, rather than just padding
				it. This parameter has no effect if :expand is set to
				nil. A child is always allocated the full height of a
				horizontal box and the full width of a vertical box.
				This option affects the other dimension.
:padding	number		Extra padding around this widget.
"
  (let* ((plist (cdr spec))
	 (orientation (plist-get plist :orientation 'horizontal))
	 (children (plist-get plist :items))
	 (box nil)
	 (child-widget nil)
	 (child-plist nil))
    (case orientation
      (vertical (setq box (gtk-vbox-new (plist-get plist :homogeneous)
					(plist-get plist :spacing))))
      (horizontal (setq box (gtk-hbox-new (plist-get plist :homogeneous)
					  (plist-get plist :spacing))))
      (otherwise (error "Unknown orientation for box: %s" orientation)))
    (mapc
     (lambda (child)
       (setq child-plist (cdr child)
	     child-widget (build-ui child))
       (if (listp child-widget)
	   (mapc (lambda (w)
		   (gtk-box-pack-start box w
				       (plist-get child-plist :expand)
				       (plist-get child-plist :fill)
				       (plist-get child-plist :padding))) child-widget)
	 (gtk-box-pack-start box child-widget
			     (plist-get child-plist :expand)
			     (plist-get child-plist :fill)
			     (plist-get child-plist :padding))))
     children)
    box))

(defun build-ui::tab-control (spec)
  "Create a notebook widget.
Properties:
:items		list		A list of UI specs to use as notebook pages.
:homogeneous	t/nil		Whether all tabs are the same width.
:orientation	top/bottom/left/right	Position of tabs
:show-tabs	t/nil		Show the tabs on screen?
:scrollable	t/nil		Allow scrolling to view all tab widgets?

Additional properties on child widgets:
:tab-label	ui		A UI spec to use for the tab label.
"
  (let* ((plist (cdr spec))
	 (notebook (gtk-notebook-new))
	 (children (plist-get plist :items))
	 (page-counter 1)
	 (label-widget nil)
	 (child-widget nil)
	 (child-plist nil))
    ;; Set all the properties
    (gtk-notebook-set-homogeneous-tabs notebook (plist-get plist :homogeneous))
    (gtk-notebook-set-scrollable notebook (plist-get plist :scrollable t))
    (gtk-notebook-set-show-tabs notebook (plist-get plist :show-tabs t))
    (gtk-notebook-set-tab-pos notebook (plist-get plist :orientation 'top))

    ;; Now fill in the tabs
    (mapc
     (lambda (child)
       (setq child-plist (cdr child)
	     child-widget (build-ui child)
	     label-widget (build-ui (plist-get child-plist :tab-label
					       (list 'label :text (format "tab %d" page-counter))))
	     page-counter (1+ page-counter))
       (gtk-notebook-append-page notebook child-widget label-widget))
     children)
    notebook))

(defun build-ui::text (spec)
  "Create a multi-line text widget.
Properties:
:editable	t/nil		Whether the user can change the contents
:word-wrap	t/nil		Automatic word wrapping?
:line-wrap	t/nil		Automatic line wrapping?
:text		string		Initial contents of the widget
:file		filename	File for initial contents (takes precedence over :text)
:face		facename	XEmacs face to use in the widget.
"
  (let* ((plist (cdr spec))
	 (text (gtk-text-new nil nil))
	 (face (plist-get plist :face 'default))
	 (info (plist-get plist :text))
	 (file (plist-get plist :file)))
    (gtk-text-set-editable text (plist-get plist :editable))
    (gtk-text-set-word-wrap text (plist-get plist :word-wrap))
    (gtk-text-set-line-wrap text (plist-get plist :line-wrap))
    (gtk-widget-set-style text 'default)

    ;; Possible convert the file portion
    (if (and file (not (stringp file)))
	(setq file (eval file)))

    (if (and info (not (stringp info)))
	(setq info (eval info)))

    (if (and file (file-exists-p file) (file-readable-p file))
	(save-excursion
	  (set-buffer (get-buffer-create " *improbable buffer name*"))
	  (insert-file-contents file)
	  (setq info (buffer-string))))

    (gtk-text-insert text
		     (face-font face)
		     (face-foreground face)
		     (face-background face)
		     info (length info))
    text))

(defun build-ui::label (spec)
  "Create a label widget.
Properties:
:text		string			Text inside the label
:face		facename		XEmacs face to use in the widget.
:justification  right/left/center	How to justify the text.
"
  (let* ((plist (cdr spec))
	 (label (gtk-label-new (plist-get plist :text))))
    (gtk-label-set-line-wrap label t)
    (gtk-label-set-justify label (plist-get plist :justification))
    (gtk-widget-set-style label (plist-get plist :face 'default))
    label))

(defun build-ui::pixmap (spec)
  "Create a multi-line text widget.
Properties:
:text		string			Text inside the label
:face		facename		XEmacs face to use in the widget.
:justification  right/left/center	How to justify the text.
"
  (let* ((plist (cdr spec))
	 (label (gtk-label-new (plist-get plist :text))))
    (gtk-label-set-line-wrap label t)
    (gtk-label-set-justify label (plist-get plist :justification))
    (gtk-widget-set-style label (plist-get plist :face 'default))
    label))

(defun build-ui::radio-group (spec)
  "A convenience when specifying a group of radio buttons."
  (declare (special build-ui::radio-group))
  (let ((build-ui::radio-group nil))
    (mapcar 'build-ui (plist-get (cdr spec) :items))))

(defun build-ui::button (spec)
  "Create a button widget.
Properties:
:type		radio/check/toggle/nil	What type of button to create.
:text		string			Text in the button.
:glyph		glyph			Image in the button.
:label		ui			A UI spec to use for the label.
:relief		normal/half/none	How to draw button edges.

NOTE: Radio buttons must be in a radio-group object for them to work.
"
  (declare (special build-ui::radio-group))
  (let* ((plist (cdr spec))
	 (button nil)
	 (button-type (plist-get plist :type 'normal)))
    (case button-type
      (radio
       (if (not (boundp 'build-ui::radio-group))
	   (error "Attempt to use a radio button outside a radio-group"))
       (setq button (gtk-radio-button-new build-ui::radio-group)
	     build-ui::radio-group (gtk-radio-button-group button)))
      (check
       (setq button (gtk-check-button-new)))
      (toggle
       (setq button (gtk-toggle-button-new)))
      (normal
       (setq button (gtk-button-new)))
      (otherwise
       (error "Unknown button type: %s" button-type)))
    (gtk-container-add
     button
     (build-ui (plist-get plist :label
			  (list 'label :text
				(plist-get plist
					   :text (format "%s button" button-type))))))
    button))

(defun build-ui::progress-gauge (spec)
  "Create a progress meter.
Properties:
:orientation		left-to-right/right-to-left/top-to-bottom/bottom-to-top
:type			discrete/continuous

"
  (let ((plist (cdr spec))
	(gauge (gtk-progress-bar-new)))
    (gtk-progress-bar-set-orientation gauge (plist-get plist :orientation 'left-to-right))
    (gtk-progress-bar-set-bar-style gauge (plist-get plist :type 'continuous))
    gauge))

(provide 'generic-widgets)

(when (featurep 'gtk)			; just loading this file should be OK
(gtk-widget-show-all
  (build-ui
   '(window :type dialog
	    :items ((tab-control
		     :homogeneous t
		     :orientation bottom
		     :items ((box :orientation vertical
				  :tab-label (label :text "vertical")
				  :items ((label :text "Vertical")
					  (progress-gauge)					  
					  (label :text "Box stacking")))
			     (box :orientation horizontal
				  :spacing 10
				  :items ((label :text "Horizontal box")
					  (label :text "stacking")))

			     (box :orientation vertical
				  :items
				  ((radio-group
				    :items ((button :type radio
						    :expand nil
						    :fill nil
						    :text "Item 1")
					    (button :type radio
						    :expand nil
						    :fill nil
						    :text "Item 2")
					    (button :type radio
						    :expand nil
						    :fill nil
						    :text "Item 3")
					    (button :type radio
						    :expand nil
						    :fill nil)))))
			     (box :orientation vertical
				  :items ((button :type check
						  :text "Item 1")
					  (button :type check
						  :text "Item 2")
					  (button :type normal
						  :text "Item 3")
					  (button :type toggle)))
			     (text :editable t
				   :word-wrap t
				   :file (locate-data-file "COPYING"))
			     (text :editable t
				   :face display-time-mail-balloon-enhance-face
				   :word-wrap t
				   :text "Text with a face on it")))))))
)