1 ;;; widgets-gtk.el --- Embedded widget support for XEmacs w/GTK primitives
3 ;; Copyright (C) 2001 Free Software Foundation, Inc.
5 ;; Maintainer: William M. Perry <wmperry@gnu.org>
6 ;; Keywords: extensions, internal, dumped
8 ;; This file is part of XEmacs.
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)
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.
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
22 ;; Free Software Foundation, 59 Temple Place - Suite 330,
23 ;; Boston, MA 02111-1307, USA.
25 ;;; Synched up with: Not in FSF.
29 ;; This file is dumped with XEmacs (when embedded widgets are compiled in).
33 (defun gtk-widget-get-callback (widget plist instance)
34 (let ((cb (plist-get plist :callback))
35 (ex (plist-get plist :callback-ex))
39 (gtk-signal-connect widget 'button-release-event
40 (lambda (widget event data)
41 (put widget 'last-event event)))
42 `(lambda (widget &rest ignored)
43 (funcall ,ex ,instance (get widget 'last-event))))
45 `(lambda (widget &rest ignored)
46 (if (functionp ,real-cb)
52 (defun gtk-widget-instantiate-button-internal (plist instance)
53 (let* ((type (or (plist-get plist :style) 'button))
54 (label (or (plist-get plist :descriptor) (symbol-name type)))
58 (setq widget (gtk-button-new-with-label label))
59 (gtk-signal-connect widget 'clicked
60 (gtk-widget-get-callback widget plist instance)))
63 (selected-p (plist-get plist :selected)))
64 (setq widget (gtk-radio-button-new-with-label nil label)
65 aux (gtk-radio-button-new-with-label
66 (gtk-radio-button-group widget)
68 (gtk-toggle-button-set-active widget (eval selected-p))
69 (gtk-signal-connect widget 'toggled
70 (gtk-widget-get-callback widget plist instance) aux)))
73 (setq widget (gtk-check-button-new-with-label label))
74 (gtk-toggle-button-set-active widget
75 (eval (plist-get plist :selected)))
76 (gtk-signal-connect widget 'toggled
77 (gtk-widget-get-callback widget plist instance))))
78 (gtk-widget-show-all widget)
81 (defun gtk-widget-instantiate-notebook-internal (plist callback)
82 (let ((widget (gtk-notebook-new))
83 (items (plist-get plist :items)))
85 ; (gtk-notebook-append-page widget
86 ; (gtk-vbox-new nil 3)
87 ; (gtk-label-new (aref (car items) 0)))
88 ; (setq items (cdr items)))
91 (defun gtk-widget-instantiate-progress-internal (plist callback)
92 (let* ((adj (gtk-adjustment-new 0.0 0.0 100.0 1.0 5.0 5.0))
93 (widget (gtk-progress-bar-new-with-adjustment adj)))
94 (gtk-adjustment-set-value adj (or (plist-get plist :value) 0.0))
97 (defun gtk-widget-instantiate-entry-internal (plist callback)
98 (let* ((widget (gtk-entry-new))
99 (default (plist-get plist :descriptor)))
104 (setq default (mapconcat 'identity default "")))
106 (error "Invalid default value: %S" default)))
107 (gtk-entry-set-text widget default)
110 (put 'button 'instantiator 'gtk-widget-instantiate-button-internal)
111 (put 'tab-control 'instantiator 'gtk-widget-instantiate-notebook-internal)
112 (put 'progress-gauge 'instantiator 'gtk-widget-instantiate-progress-internal)
113 (put 'tree-view 'instantiator 'ignore)
114 (put 'edit-field 'instantiator 'gtk-widget-instantiate-entry-internal)
115 (put 'combo-box 'instantiator 'ignore)
116 (put 'label 'instantiator 'ignore)
117 (put 'layout 'instantiator 'ignore)
119 (defun gtk-widget-instantiate-internal (instance
124 "The lisp side of widget/glyph instantiation code."
125 (let* ((type (aref instantiator 0))
126 (plist (cdr (map 'list 'identity instantiator)))
127 (widget (funcall (or (get type 'instantiator) 'ignore)
129 ; (add-timeout 0.1 (lambda (obj)
130 ; (gtk-widget-set-style obj
131 ; (gtk-widget-get-style
132 ; (frame-property nil 'text-widget))))
137 (defun gtk-widget-property-internal ()
140 (defun gtk-widget-redisplay-internal ()
143 (provide 'widgets-gtk)