git.chise.org Git - chise/xemacs-chise.git.1/blob - lisp/widgets-gtk.el

   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-get-callback (widget plist instance)
  34   (let ((cb (plist-get plist :callback))
  35         (ex (plist-get plist :callback-ex))
  36         (real-cb nil))
  37     (cond
  38      (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))))
  44      (cb
  45       `(lambda (widget &rest ignored)
  46          (if (functionp ,real-cb)
  47              (funcall ,real-cb)
  48            (eval ,real-cb))))
  49      (t
  50       nil))))
  51
  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)))
  55          (widget nil))
  56     (case type
  57       (button
  58        (setq widget (gtk-button-new-with-label label))
  59        (gtk-signal-connect widget 'clicked
  60                            (gtk-widget-get-callback widget plist instance)))
  61       (radio
  62        (let ((aux nil)
  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)
  67                     "bogus sibling"))
  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)))
  71       (otherwise
  72        ;; Check boxes
  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)
  79     widget))
  80
  81 (defun gtk-widget-instantiate-notebook-internal (plist callback)
  82   (let ((widget (gtk-notebook-new))
  83         (items (plist-get plist :items)))
  84 ;     (while 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)))
  89     widget))
  90
  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))
  95     widget))
  96
  97 (defun gtk-widget-instantiate-entry-internal (plist callback)
  98   (let* ((widget (gtk-entry-new))
  99          (default (plist-get plist :descriptor)))
 100     (cond
 101      ((stringp default)
 102       nil)
 103      ((sequencep default)
 104       (setq default (mapconcat 'identity default "")))
 105      (t
 106       (error "Invalid default value: %S" default)))
 107     (gtk-entry-set-text widget default)
 108     widget))
 109
 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)
 118
 119 (defun gtk-widget-instantiate-internal (instance
 120                                         instantiator
 121                                         pointer-fg
 122                                         pointer-bg
 123                                         domain)
 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)
 128                           plist instance)))
 129 ;     (add-timeout 0.1 (lambda (obj)
 130 ;                      (gtk-widget-set-style obj
 131 ;                                            (gtk-widget-get-style
 132 ;                                             (frame-property nil 'text-widget))))
 133 ;                widget)
 134     (setq x widget)
 135     widget))
 136
 137 (defun gtk-widget-property-internal ()
 138   nil)
 139
 140 (defun gtk-widget-redisplay-internal ()
 141   nil)
 142
 143 (provide 'widgets-gtk)