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.4 2005-04-19 08:11:39 espen Exp $
  19
  20
  21 (in-package "GTK")
  22
  23 ;;; Action
  24
  25 (defmethod initialize-instance ((action action) &key callback)
  26   (call-next-method)
  27   (when callback
  28     (apply #'signal-connect action 'activate (mklist callback))))
  29
  30 (defmethod action-accelerator ((action action))
  31   (object-data action 'accelerator))
  32
  33 (defbinding (action-is-sensitive-p "gtk_action_is_sensitive") () boolean
  34   (action action))
  35
  36 (defbinding (action-is-visible-p "gtk_action_is_visible") () boolean
  37   (action action))
  38
  39 (defbinding action-activate () nil
  40   (action action))
  41
  42
  43 ;;; Action Group
  44
  45 (defmethod initialize-instance ((action-group action-group) &rest initargs
  46                                 &key action actions)
  47   (declare (ignore action actions))
  48   (prog1
  49       (call-next-method)
  50     (initial-add action-group #'action-group-add-action
  51      initargs :action :actions)))
  52
  53 (defbinding action-group-get-action () action
  54   (action-group action-group)
  55   (name string))
  56
  57 (defbinding action-group-list-actions () (glist action)
  58   (action-group action-group))
  59
  60 (defbinding %action-group-add-action () nil
  61   (action-group action-group)
  62   (action action))
  63
  64 (defbinding %action-group-add-action-with-accel () nil
  65   (action-group action-group)
  66   (action action)
  67   (accelerator (or null string)))
  68
  69 (defun action-group-add-action (action-group action)
  70   (if (slot-boundp action 'accelerator)
  71       (%action-group-add-action-with-accel action-group action (action-accelerator action))
  72     (%action-group-add-action action-group action)))
  73
  74 (defbinding action-group-remove-action () nil
  75   (action-group action-group)
  76   (action action))
  77
  78
  79 ;;; Radio Action
  80
  81 (defmethod initialize-instance ((action radio-action) &key group)
  82   (call-next-method)
  83   (setf (slot-value action 'self) (sap-int (proxy-location action)))
  84   (when group
  85     (add-to-radio-group action group)))
  86
  87 (defbinding %radio-action-get-group () pointer
  88   (radio-action radio-action))
  89
  90 (defbinding %radio-action-set-group () nil
  91   (radio-button radio-button)
  92   (group pointer))
  93
  94 (defmethod add-to-radio-group ((action1 radio-action) (action2 radio-action))
  95   "Add ACTION1 to the group which ACTION2 belongs to."
  96   (%radio-action-set-group action1 (%radio-action-get-group action2)))
  97
  98 (defmethod activate-radio-widget ((action radio-action))
  99   (action-activate action))
 100
 101 (defmethod add-activate-callback ((action radio-action) function &key object after)
 102   (%add-activate-callback action 'activate function object after))
 103
 104 (defbinding (radio-action-get-current "gtk_radio_action_get_current_value")
 105     () radio-action
 106   "Returns the current active radio action in the group the give radio action belongs to."
 107   (radio-action radio-action))
 108
 109 (defun radio-action-get-current-value (action)
 110   (radio-value-action (radio-action-get-current action)))
 111
 112
 113
 114 ;;; Toggle Action
 115
 116 (defmethod initialize-instance ((action toggle-action) &rest initargs &key callback)
 117   (remf initargs :callback)
 118   (apply #'call-next-method action initargs)
 119   (when callback
 120     (destructuring-bind (function &key object after) (mklist callback)
 121       (signal-connect action 'activate
 122        (if object
 123            #'(lambda (object)
 124                (funcall function object (toggle-action-active-p action)))
 125          #'(lambda ()
 126              (funcall function (toggle-action-active-p action))))
 127        :object object :after after)))
 128   (when (toggle-action-active-p action)
 129     (action-activate action)))
 130
 131 (defbinding toggle-action-toggled () nil
 132   (toggle-action toggle-action))
 133
 134
 135 ;;; UI Manager
 136
 137 (defmethod initialize-instance ((ui-manager ui-manager) &rest initargs
 138                                 &key ui action-group)
 139   (declare (ignore ui action-group))
 140   (call-next-method)
 141   (mapc #'(lambda (action-group)
 142             (ui-manager-insert-action-group ui-manager action-group))
 143         (get-all initargs :action-group))
 144   (mapc #'(lambda (ui)
 145             (ui-manager-add-ui ui-manager ui))
 146         (get-all initargs :ui)))
 147
 148
 149 (defbinding ui-manager-insert-action-group
 150     (ui-manager action-group &optional (pos :end)) nil
 151   (ui-manager ui-manager)
 152   (action-group action-group)
 153   ((case pos
 154      (:first 0)
 155      (:end -1)
 156      (t pos)) int))
 157
 158 (defbinding ui-manager-remove-action-group () nil
 159   (ui-manager ui-manager)
 160   (action-group action-group))
 161
 162 (defbinding ui-manager-get-widget () widget
 163   (ui-manager ui-manager)
 164   (path string))
 165
 166 (defbinding ui-manager-get-toplevels () (glist widget)
 167   (ui-manager ui-manager)
 168   (types ui-manager-item-type))
 169
 170 (defbinding ui-manager-get-action () action
 171   (ui-manager ui-manager)
 172   (path string))
 173
 174 (defbinding %ui-manager-add-ui-from-string (ui-manager ui) int
 175   (ui-manager ui-manager)
 176   (ui string)
 177   ((length ui) int)
 178   (gerror pointer :out))
 179
 180 (defmethod ui-manager-add-ui ((ui-manager ui-manager) (ui-spec string))
 181   (let ((id (%ui-manager-add-ui-from-string ui-manager ui-spec)))
 182     (when (zerop id)
 183       (error "We need to handle GError in som way"))
 184     id))
 185
 186 (defbinding %ui-manager-add-ui-from-file () int
 187   (ui-manager ui-manager)
 188   (filename pathname)
 189   (gerror pointer :out))
 190
 191 (defmethod ui-manager-add-ui ((ui-manager ui-manager) (path pathname))
 192   (let ((id (%ui-manager-add-ui-from-file ui-manager path)))
 193     (when (zerop id)
 194       (error "We need to handle GError in som way"))
 195     id))
 196
 197 (defbinding %ui-manager-new-merge-id () unsigned-int
 198   (ui-manager ui-manager))
 199
 200 (defbinding %ui-manager-add-ui () nil
 201   (ui-manager ui-manager)
 202   (merge-id unsigned-int)
 203   (path string)
 204   (name string)
 205   (action (or null string))
 206   (type ui-manager-item-type)
 207   (top boolean))
 208
 209 (defvar *valid-ui-elements*
 210   '((:ui :menubar :toolbar :popup :accelerator)
 211     (:menubar :menuitem :separator :placeholder :menu)
 212     (:menu :menuitem :separator :placehoder :menu)
 213     (:popup :menuitem :separator :placehoder :menu)
 214     (:toolbar :toolitem :separator :placehoder)
 215     (:placeholder :menuitem :toolitem :separator :placeholder :menu)
 216     (:menuitem)
 217     (:toolitem)
 218     (:separator)
 219     (:accelerator)))
 220
 221 (defvar *anonymous-element-counter* 0)
 222 (internal *anonymous-element-counter*)
 223
 224 (defmethod ui-manager-add-ui ((ui-manager ui-manager) (ui-spec list))
 225   (let ((id (%ui-manager-new-merge-id ui-manager)))
 226     (labels
 227         ((parse-ui-spec (path ui-spec element)
 228            (loop
 229             for definition in ui-spec
 230             do (destructuring-bind (type &optional name &rest rest)
 231                    (mklist definition)
 232                  (cond
 233                   ((not (find type (cdr (assoc element *valid-ui-elements*))))
 234                    (ui-manager-remove-ui ui-manager id)
 235                    (error "~S not valid subelement in ~S" type element))
 236                   ((multiple-value-bind (action children)
 237                        (if (and rest (atom (first rest))
 238                                 (not (keywordp (first rest))))
 239                            (values (first rest) (rest rest))
 240                          (values name rest))
 241                      (%ui-manager-add-ui ui-manager
 242                       id (or path "/")
 243                       (or name (format nil "~A~D"
 244                                 (string-capitalize type)
 245                                 (incf *anonymous-element-counter*)))
 246                       action type nil)
 247                      (when children
 248                        (parse-ui-spec (concatenate 'string path "/" name)
 249                                       children type)))))))))
 250       (parse-ui-spec nil ui-spec :ui))
 251     id))
 252
 253 (defbinding ui-manager-remove-ui () nil
 254   (ui-manager ui-manager)
 255   (merge-id unsigned-int))
 256
 257 (defbinding ui-manager-get-ui () string
 258   (ui-manager ui-manager))
 259
 260 (defbinding ui-manager-ensure-update () nil
 261   (ui-manager ui-manager))