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))
2367
+ − 92 ;(items (plist-get plist :items))
+ − 93 )
2168
+ − 94 ; (while items
+ − 95 ; (gtk-notebook-append-page widget
+ − 96 ; (gtk-vbox-new nil 3)
+ − 97 ; (gtk-label-new (aref (car items) 0)))
+ − 98 ; (setq items (cdr items)))
462
+ − 99 widget))
+ − 100
738
+ − 101 (defun gtk-widget-instantiate-progress-internal (plist instance)
462
+ − 102 (let* ((adj (gtk-adjustment-new 0.0 0.0 100.0 1.0 5.0 5.0))
+ − 103 (widget (gtk-progress-bar-new-with-adjustment adj)))
+ − 104 (gtk-adjustment-set-value adj (or (plist-get plist :value) 0.0))
+ − 105 widget))
+ − 106
738
+ − 107 (defun gtk-widget-instantiate-entry-internal (plist instance)
462
+ − 108 (let* ((widget (gtk-entry-new))
+ − 109 (default (plist-get plist :descriptor)))
+ − 110 (cond
+ − 111 ((stringp default)
+ − 112 nil)
+ − 113 ((sequencep default)
+ − 114 (setq default (mapconcat 'identity default "")))
+ − 115 (t
+ − 116 (error "Invalid default value: %S" default)))
+ − 117 (gtk-entry-set-text widget default)
+ − 118 widget))
+ − 119
+ − 120 (put 'button 'instantiator 'gtk-widget-instantiate-button-internal)
+ − 121 (put 'tab-control 'instantiator 'gtk-widget-instantiate-notebook-internal)
+ − 122 (put 'progress-gauge 'instantiator 'gtk-widget-instantiate-progress-internal)
+ − 123 (put 'tree-view 'instantiator 'ignore)
+ − 124 (put 'edit-field 'instantiator 'gtk-widget-instantiate-entry-internal)
+ − 125 (put 'combo-box 'instantiator 'ignore)
+ − 126 (put 'label 'instantiator 'ignore)
+ − 127 (put 'layout 'instantiator 'ignore)
+ − 128
+ − 129 (defun gtk-widget-instantiate-internal (instance
+ − 130 instantiator
+ − 131 pointer-fg
+ − 132 pointer-bg
+ − 133 domain)
+ − 134 "The lisp side of widget/glyph instantiation code."
+ − 135 (let* ((type (aref instantiator 0))
+ − 136 (plist (cdr (map 'list 'identity instantiator)))
+ − 137 (widget (funcall (or (get type 'instantiator) 'ignore)
738
+ − 138 plist instance)))
2168
+ − 139 ; (add-timeout 0.1 (lambda (obj)
+ − 140 ; (gtk-widget-set-style obj
+ − 141 ; (gtk-widget-get-style
+ − 142 ; (frame-property nil 'text-widget))))
+ − 143 ; widget)
462
+ − 144 widget))
+ − 145
+ − 146 (defun gtk-widget-property-internal ()
+ − 147 nil)
+ − 148
+ − 149 (defun gtk-widget-redisplay-internal ()
+ − 150 nil)
+ − 151
+ − 152 (provide 'widgets-gtk)