chiark - git - mdw - clg/blob - gtk/gtkaction.lisp

   1 ;; Common Lisp bindings for GTK+ v2.0
   2 ;; Copyright (C) 1999-2001 Espen S. Johnsen <esj@stud.cs.uit.no>
   3 ;;
   4 ;; This library is free software; you can redistribute it and/or
   5 ;; modify it under the terms of the GNU Lesser General Public
   6 ;; License as published by the Free Software Foundation; either
   7 ;; version 2 of the License, or (at your option) any later version.
   8 ;;
   9 ;; This library is distributed in the hope that it will be useful,
  10 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12 ;; Lesser General Public License for more details.
  13 ;;
  14 ;; You should have received a copy of the GNU Lesser General Public
  15 ;; License along with this library; if not, write to the Free Software
  16 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  17
  18 ;; $Id: gtkaction.lisp,v 1.3 2005-02-03 23:09:09 espen Exp $
  19
  20
  21 (in-package "GTK")
  22
  23 ;;; Action
  24
  25 (defmethod initialize-instance ((action action) &key accelerator)
  26   (call-next-method)
  27   (setf (object-data action 'accelerator) accelerator))
  28
  29 (defmethod action-accelerator ((action action))
  30   (object-data action 'accelerator))
  31
  32 (defbinding (action-is-sensitive-p "gtk_action_is_sensitive") () boolean
  33   (action action))
  34
  35 (defbinding (action-is-visible-p "gtk_action_is_visible") () boolean
  36   (action action))
  37
  38 (defbinding action-activate () nil
  39   (action action))
  40
  41
  42 ;;; Action Group
  43
  44 (defmethod initialize-instance ((action-group action-group) &rest initargs
  45                                 &key action actions)
  46   (declare (ignore action actions))
  47   (prog1
  48       (call-next-method)
  49     (initial-add action-group #'action-group-add-action
  50      initargs :action :actions)))
  51
  52 (defbinding action-group-get-action () action
  53   (action-group action-group)
  54   (name string))
  55
  56 (defbinding action-group-list-actions () (glist action)
  57   (action-group action-group))
  58
  59 (defbinding %action-group-add-action () nil
  60   (action-group action-group)
  61   (action action))
  62
  63 (defbinding %action-group-add-action-with-accel () nil
  64   (action-group action-group)
  65   (action action)
  66   (accelerator (or null string)))
  67
  68 (defun action-group-add-action (action-group action)
  69   (multiple-value-bind (accelerator accelerator-p)
  70       (object-data action 'accelerator)
  71     (if accelerator-p
  72         (%action-group-add-action-with-accel action-group action accelerator)
  73       (%action-group-add-action action-group action))))
  74
  75 (defbinding action-group-remove-action () nil
  76   (action-group action-group)
  77   (action action))
  78
  79
  80 ;;; Radio Action
  81
  82 (defmethod initialize-instance ((action radio-action) &key group value)
  83   (call-next-method)
  84   (setf (slot-value action '%value) (sap-int (proxy-location action)))
  85   (setf (object-data action 'radio-action-value) value)
  86   (when group
  87     (radio-action-add-to-group action group)))
  88
  89 (defmethod radio-value-action ((action radio-action))
  90   (object-data action 'radio-action-value))
  91
  92 (defbinding %radio-action-get-group () pointer
  93   (radio-action radio-action))
  94
  95 (defbinding %radio-action-set-group () nil
  96   (radio-button radio-button)
  97   (group pointer))
  98
  99 (defun radio-action-add-to-group (action1 action2)
 100   "Add ACTION1 to the group which ACTION2 belongs to."
 101   (%radio-action-set-group action1 (%radio-action-get-group action2)))
 102
 103 (defbinding (radio-action-get-current "gtk_radio_action_get_current_value")
 104     () radio-action
 105   (radio-action radio-action))
 106
 107 (defun radio-action-get-current-value (action)
 108   (radio-value-action (radio-action-get-current action)))
 109
 110
 111
 112 ;;; Toggle Action
 113
 114 (defbinding toggle-action-toggled () nil
 115   (toggle-action toggle-action))
 116
 117
 118
 119 ;;; UI Manager
 120
 121 (defmethod initialize-instance ((ui-manager ui-manager) &rest initargs
 122                                 &key ui action-group)
 123   (declare (ignore ui action-group))
 124   (call-next-method)
 125   (mapc #'(lambda (action-group)
 126             (ui-manager-insert-action-group ui-manager action-group))
 127         (get-all initargs :action-group))
 128   (mapc #'(lambda (ui)
 129             (ui-manager-add-ui ui-manager ui))
 130         (get-all initargs :ui)))
 131
 132
 133 (defbinding ui-manager-insert-action-group
 134     (ui-manager action-group &optional (pos :end)) nil
 135   (ui-manager ui-manager)
 136   (action-group action-group)
 137   ((case pos
 138      (:first 0)
 139      (:end -1)
 140      (t pos)) int))
 141
 142 (defbinding ui-manager-remove-action-group () nil
 143   (ui-manager ui-manager)
 144   (action-group action-group))
 145
 146 (defbinding ui-manager-get-widget () widget
 147   (ui-manager ui-manager)
 148   (path string))
 149
 150 (defbinding ui-manager-get-toplevels () (glist widget)
 151   (ui-manager ui-manager)
 152   (types ui-manager-item-type))
 153
 154 (defbinding ui-manager-get-action () action
 155   (ui-manager ui-manager)
 156   (path string))
 157
 158 (defbinding %ui-manager-add-ui-from-string (ui-manager ui) int
 159   (ui-manager ui-manager)
 160   (ui string)
 161   ((length ui) int)
 162   (gerror pointer :out))
 163
 164 (defmethod ui-manager-add-ui ((ui-manager ui-manager) (ui-spec string))
 165   (let ((id (%ui-manager-add-ui-from-string ui-manager ui-spec)))
 166     (when (zerop id)
 167       (error "We need to handle GError in som way"))
 168     id))
 169
 170 (defbinding %ui-manager-add-ui-from-file () int
 171   (ui-manager ui-manager)
 172   (filename pathname)
 173   (gerror pointer :out))
 174
 175 (defmethod ui-manager-add-ui ((ui-manager ui-manager) (path pathname))
 176   (let ((id (%ui-manager-add-ui-from-file ui-manager path)))
 177     (when (zerop id)
 178       (error "We need to handle GError in som way"))
 179     id))
 180
 181 (defbinding %ui-manager-new-merge-id () unsigned-int
 182   (ui-manager ui-manager))
 183
 184 (defbinding %ui-manager-add-ui () nil
 185   (ui-manager ui-manager)
 186   (merge-id unsigned-int)
 187   (path string)
 188   (name string)
 189   (action (or null string))
 190   (type ui-manager-item-type)
 191   (top boolean))
 192
 193 (defvar *valid-ui-elements*
 194   '((:ui :menubar :toolbar :popup :accelerator)
 195     (:menubar :menuitem :separator :placeholder :menu)
 196     (:menu :menuitem :separator :placehoder :menu)
 197     (:popup :menuitem :separator :placehoder :menu)
 198     (:toolbar :toolitem :separator :placehoder)
 199     (:placeholder :menuitem :toolitem :separator :placeholder :menu)
 200     (:menuitem)
 201     (:toolitem)
 202     (:separator)
 203     (:accelerator)))
 204
 205 (defmethod ui-manager-add-ui ((ui-manager ui-manager) (ui-spec list))
 206   (let ((id (%ui-manager-new-merge-id ui-manager)))
 207     (labels
 208         ((parse-ui-spec (path ui-spec element)
 209            (loop
 210             for definition in ui-spec
 211             do (destructuring-bind (type &optional name &rest rest)
 212                    (mklist definition)
 213                  (cond
 214                   ((not (find type (cdr (assoc element *valid-ui-elements*))))
 215                    (ui-manager-remove-ui ui-manager id)
 216                    (error "~S not valid subelement in ~S" type element))
 217                   ((multiple-value-bind (action children)
 218                        (if (and rest (atom (first rest))
 219                                 (not (keywordp (first rest))))
 220                            (values (first rest) (rest rest))
 221                          (values name rest))
 222                      (%ui-manager-add-ui ui-manager id (or path "/") name action type nil)
 223                      (when children
 224                        (parse-ui-spec (concatenate 'string path "/" name)
 225                                       children type)))))))))
 226       (parse-ui-spec nil ui-spec :ui))
 227     id))
 228
 229 (defbinding ui-manager-remove-ui () nil
 230   (ui-manager ui-manager)
 231   (merge-id unsigned-int))
 232
 233 (defbinding ui-manager-get-ui () string
 234   (ui-manager ui-manager))
 235
 236 (defbinding ui-manager-ensure-update () nil
 237   (ui-manager ui-manager))