Mercurial > hg > xemacs-beta

comparison lisp/widgets-gtk.el @ 462:0784d089fdc9 r21-2-46

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
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 ;;; 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
31 (defvar foo)
32
33 (defun gtk-widget-instantiate-button-internal (plist callback)
34 (let* ((type (or (plist-get plist :style) 'button))
35 (label (or (plist-get plist :descriptor) (symbol-name type)))
36 (widget nil))
37 (case type
38 (button
39 (setq widget (gtk-button-new-with-label label))
40 (gtk-signal-connect widget 'clicked (lambda (wid real-cb)
41 (if (functionp real-cb)
42 (funcall real-cb)
43 (eval real-cb)))
44 callback))
45 (radio
46 (let ((aux nil)
47 (selected-p (plist-get plist :selected)))
48 (setq widget (gtk-radio-button-new-with-label nil label)
49 aux (gtk-radio-button-new-with-label
50 (gtk-radio-button-group widget)
51 "bogus sibling"))
52 (gtk-toggle-button-set-active widget (eval selected-p))
53 (gtk-signal-connect widget 'toggled
54 (lambda (wid data)
55 ;; data is (real-cb . sibling)
56 )
57 (cons callback aux))))
58 (otherwise
59 ;; Check boxes
60 (setq widget (gtk-check-button-new-with-label label))
61 (gtk-toggle-button-set-active widget
62 (eval (plist-get plist :selected)))
63 (gtk-signal-connect widget 'toggled
64 (lambda (wid real-cb)
65 (if (functionp real-cb)
66 (funcall real-cb)
67 (eval real-cb)))
68 callback)))
69
70 (gtk-widget-show-all widget)
71 widget))
72
73 (defun gtk-widget-instantiate-notebook-internal (plist callback)
74 (let ((widget (gtk-notebook-new))
75 (items (plist-get plist :items)))
76 (while items
77 (gtk-notebook-append-page widget
78 (gtk-vbox-new nil 3)
79 (gtk-label-new (aref (car items) 0)))
80 (setq items (cdr items)))
81 widget))
82
83 (defun gtk-widget-instantiate-progress-internal (plist callback)
84 (let* ((adj (gtk-adjustment-new 0.0 0.0 100.0 1.0 5.0 5.0))
85 (widget (gtk-progress-bar-new-with-adjustment adj)))
86 (gtk-adjustment-set-value adj (or (plist-get plist :value) 0.0))
87 widget))
88
89 (defun gtk-widget-instantiate-entry-internal (plist callback)
90 (let* ((widget (gtk-entry-new))
91 (default (plist-get plist :descriptor)))
92 (cond
93 ((stringp default)
94 nil)
95 ((sequencep default)
96 (setq default (mapconcat 'identity default "")))
97 (t
98 (error "Invalid default value: %S" default)))
99 (gtk-entry-set-text widget default)
100 widget))
101
102 (put 'button 'instantiator 'gtk-widget-instantiate-button-internal)
103 (put 'tab-control 'instantiator 'gtk-widget-instantiate-notebook-internal)
104 (put 'progress-gauge 'instantiator 'gtk-widget-instantiate-progress-internal)
105 (put 'tree-view 'instantiator 'ignore)
106 (put 'edit-field 'instantiator 'gtk-widget-instantiate-entry-internal)
107 (put 'combo-box 'instantiator 'ignore)
108 (put 'label 'instantiator 'ignore)
109 (put 'layout 'instantiator 'ignore)
110
111 (defun gtk-widget-instantiate-internal (instance
112 instantiator
113 pointer-fg
114 pointer-bg
115 domain)
116 "The lisp side of widget/glyph instantiation code."
117 (let* ((type (aref instantiator 0))
118 (plist (cdr (map 'list 'identity instantiator)))
119 (widget (funcall (or (get type 'instantiator) 'ignore)
120 plist (or (plist-get plist :callback) 'ignore))))
121 (add-timeout 0.1 (lambda (obj)
122 (gtk-widget-set-style obj
123 (gtk-widget-get-style
124 (frame-property nil 'text-widget))))
125 widget)
126 (setq x widget)
127 widget))
128
129 (defun gtk-widget-property-internal ()
130 nil)
131
132 (defun gtk-widget-redisplay-internal ()
133 nil)
134
135 (provide 'widgets-gtk)