|
462
|
1 ;;; widgets-gtk.el --- Embedded widget support for XEmacs w/GTK primitives
|
|
|
2
|
|
|
3 ;; Copyright (C) 2001 Free Software Foundation, Inc.
|
|
|
4
|
|
|
5 ;; Maintainer: William M. Perry <wmperry@gnu.org>
|
|
|
6 ;; Keywords: extensions, internal, 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
|
|
|
22 ;; Free Software Foundation, 59 Temple Place - Suite 330,
|
|
|
23 ;; Boston, MA 02111-1307, USA.
|
|
|
24
|
|
|
25 ;;; Synched up with: Not in FSF.
|
|
|
26
|
|
|
27 ;;; Commentary:
|
|
|
28
|
|
|
29 ;; This file is dumped with XEmacs (when embedded widgets are compiled in).
|
|
|
30
|
|
502
|
31 (globally-declare-fboundp
|
|
|
32 '(gtk-button-new-with-label
|
|
|
33 gtk-signal-connect
|
|
|
34 gtk-radio-button-new-with-label gtk-radio-button-group
|
|
|
35 gtk-toggle-button-set-active gtk-check-button-new-with-label
|
|
|
36 gtk-widget-show-all gtk-notebook-new gtk-notebook-append-page
|
|
|
37 gtk-vbox-new gtk-label-new gtk-adjustment-new
|
|
|
38 gtk-progress-bar-new-with-adjustment gtk-adjustment-set-value
|
|
|
39 gtk-entry-new gtk-entry-set-text gtk-widget-set-style
|
|
|
40 gtk-widget-get-style))
|
|
|
41
|
|
738
|
42 (defun gtk-widget-get-callback (widget plist instance)
|
|
|
43 (let ((cb (plist-get plist :callback))
|
|
|
44 (ex (plist-get plist :callback-ex))
|
|
|
45 (real-cb nil))
|
|
|
46 (cond
|
|
|
47 (ex
|
|
|
48 (gtk-signal-connect widget 'button-release-event
|
|
|
49 (lambda (widget event data)
|
|
|
50 (put widget 'last-event event)))
|
|
|
51 `(lambda (widget &rest ignored)
|
|
|
52 (funcall ,ex ,instance (get widget 'last-event))))
|
|
|
53 (cb
|
|
|
54 `(lambda (widget &rest ignored)
|
|
|
55 (if (functionp ,real-cb)
|
|
|
56 (funcall ,real-cb)
|
|
|
57 (eval ,real-cb))))
|
|
|
58 (t
|
|
|
59 nil))))
|
|
462
|
60
|
|
738
|
61 (defun gtk-widget-instantiate-button-internal (plist instance)
|
|
462
|
62 (let* ((type (or (plist-get plist :style) 'button))
|
|
|
63 (label (or (plist-get plist :descriptor) (symbol-name type)))
|
|
|
64 (widget nil))
|
|
|
65 (case type
|
|
|
66 (button
|
|
|
67 (setq widget (gtk-button-new-with-label label))
|
|
738
|
68 (gtk-signal-connect widget 'clicked
|
|
|
69 (gtk-widget-get-callback widget plist instance)))
|
|
462
|
70 (radio
|
|
|
71 (let ((aux nil)
|
|
|
72 (selected-p (plist-get plist :selected)))
|
|
|
73 (setq widget (gtk-radio-button-new-with-label nil label)
|
|
|
74 aux (gtk-radio-button-new-with-label
|
|
|
75 (gtk-radio-button-group widget)
|
|
|
76 "bogus sibling"))
|
|
|
77 (gtk-toggle-button-set-active widget (eval selected-p))
|
|
|
78 (gtk-signal-connect widget 'toggled
|
|
738
|
79 (gtk-widget-get-callback widget plist instance) aux)))
|
|
462
|
80 (otherwise
|
|
|
81 ;; Check boxes
|
|
|
82 (setq widget (gtk-check-button-new-with-label label))
|
|
|
83 (gtk-toggle-button-set-active widget
|
|
|
84 (eval (plist-get plist :selected)))
|
|
|
85 (gtk-signal-connect widget 'toggled
|
|
738
|
86 (gtk-widget-get-callback widget plist instance))))
|
|
462
|
87 (gtk-widget-show-all widget)
|
|
|
88 widget))
|
|
|
89
|
|
738
|
90 (defun gtk-widget-instantiate-notebook-internal (plist instance)
|
|
462
|
91 (let ((widget (gtk-notebook-new))
|
|
|
92 (items (plist-get plist :items)))
|
|
|
93 (while items
|
|
|
94 (gtk-notebook-append-page widget
|
|
|
95 (gtk-vbox-new nil 3)
|
|
|
96 (gtk-label-new (aref (car items) 0)))
|
|
|
97 (setq items (cdr items)))
|
|
|
98 widget))
|
|
|
99
|
|
738
|
100 (defun gtk-widget-instantiate-progress-internal (plist instance)
|
|
462
|
101 (let* ((adj (gtk-adjustment-new 0.0 0.0 100.0 1.0 5.0 5.0))
|
|
|
102 (widget (gtk-progress-bar-new-with-adjustment adj)))
|
|
|
103 (gtk-adjustment-set-value adj (or (plist-get plist :value) 0.0))
|
|
|
104 widget))
|
|
|
105
|
|
738
|
106 (defun gtk-widget-instantiate-entry-internal (plist instance)
|
|
462
|
107 (let* ((widget (gtk-entry-new))
|
|
|
108 (default (plist-get plist :descriptor)))
|
|
|
109 (cond
|
|
|
110 ((stringp default)
|
|
|
111 nil)
|
|
|
112 ((sequencep default)
|
|
|
113 (setq default (mapconcat 'identity default "")))
|
|
|
114 (t
|
|
|
115 (error "Invalid default value: %S" default)))
|
|
|
116 (gtk-entry-set-text widget default)
|
|
|
117 widget))
|
|
|
118
|
|
|
119 (put 'button 'instantiator 'gtk-widget-instantiate-button-internal)
|
|
|
120 (put 'tab-control 'instantiator 'gtk-widget-instantiate-notebook-internal)
|
|
|
121 (put 'progress-gauge 'instantiator 'gtk-widget-instantiate-progress-internal)
|
|
|
122 (put 'tree-view 'instantiator 'ignore)
|
|
|
123 (put 'edit-field 'instantiator 'gtk-widget-instantiate-entry-internal)
|
|
|
124 (put 'combo-box 'instantiator 'ignore)
|
|
|
125 (put 'label 'instantiator 'ignore)
|
|
|
126 (put 'layout 'instantiator 'ignore)
|
|
|
127
|
|
|
128 (defun gtk-widget-instantiate-internal (instance
|
|
|
129 instantiator
|
|
|
130 pointer-fg
|
|
|
131 pointer-bg
|
|
|
132 domain)
|
|
|
133 "The lisp side of widget/glyph instantiation code."
|
|
|
134 (let* ((type (aref instantiator 0))
|
|
|
135 (plist (cdr (map 'list 'identity instantiator)))
|
|
|
136 (widget (funcall (or (get type 'instantiator) 'ignore)
|
|
738
|
137 plist instance)))
|
|
462
|
138 (add-timeout 0.1 (lambda (obj)
|
|
|
139 (gtk-widget-set-style obj
|
|
|
140 (gtk-widget-get-style
|
|
|
141 (frame-property nil 'text-widget))))
|
|
|
142 widget)
|
|
|
143 widget))
|
|
|
144
|
|
|
145 (defun gtk-widget-property-internal ()
|
|
|
146 nil)
|
|
|
147
|
|
|
148 (defun gtk-widget-redisplay-internal ()
|
|
|
149 nil)
|
|
|
150
|
|
|
151 (provide 'widgets-gtk)
|
