cgit.sxemacs.org Git - sxemacs/blob - lisp/widgets-gtk.el

   1 ;;; widgets-gtk.el --- Embedded widget support for SXEmacs 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 SXEmacs.
   9
  10 ;; SXEmacs is free software: you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation, either version 3 of the License, or
  13 ;; (at your option) any later version.
  14
  15 ;; SXEmacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 ;;; Synched up with: Not in FSF.
  24
  25 ;;; Commentary:
  26
  27 ;; This file is dumped with SXEmacs (when embedded widgets are compiled in).
  28
  29 (globally-declare-fboundp
  30  '(gtk-button-new-with-label
  31    gtk-signal-connect
  32    gtk-radio-button-new-with-label gtk-radio-button-group
  33    gtk-toggle-button-set-active gtk-check-button-new-with-label
  34    gtk-widget-show-all gtk-notebook-new gtk-notebook-append-page
  35    gtk-vbox-new gtk-label-new gtk-adjustment-new
  36    gtk-progress-bar-new-with-adjustment gtk-adjustment-set-value
  37    gtk-entry-new gtk-entry-set-text gtk-widget-set-style
  38    gtk-widget-get-style))
  39
  40 (defvar foo)
  41
  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))))
  60
  61 (defun gtk-widget-instantiate-button-internal (plist instance)
  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))
  68        (gtk-signal-connect widget 'clicked
  69                            (gtk-widget-get-callback widget plist instance)))
  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
  79                              (gtk-widget-get-callback widget plist instance) aux)))
  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
  86                            (gtk-widget-get-callback widget plist instance))))
  87     (gtk-widget-show-all widget)
  88     widget))
  89
  90 (defun gtk-widget-instantiate-notebook-internal (plist callback)
  91   (let ((widget (gtk-notebook-new))
  92         ;(items (plist-get plist :items)))
  93         )
  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)))
  99     widget))
 100
 101 (defun gtk-widget-instantiate-progress-internal (plist callback)
 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
 107 (defun gtk-widget-instantiate-entry-internal (plist callback)
 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)
 138                           plist instance)))
 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)
 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)