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

   1 ;; Common Lisp bindings for GTK+ v2.x
   2 ;; Copyright 2005 Espen S. Johnsen <espen@users.sf.net>
   3 ;;
   4 ;; Permission is hereby granted, free of charge, to any person obtaining
   5 ;; a copy of this software and associated documentation files (the
   6 ;; "Software"), to deal in the Software without restriction, including
   7 ;; without limitation the rights to use, copy, modify, merge, publish,
   8 ;; distribute, sublicense, and/or sell copies of the Software, and to
   9 ;; permit persons to whom the Software is furnished to do so, subject to
  10 ;; the following conditions:
  11 ;;
  12 ;; The above copyright notice and this permission notice shall be
  13 ;; included in all copies or substantial portions of the Software.
  14 ;;
  15 ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  16 ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
  17 ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
  18 ;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
  19 ;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
  20 ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
  21 ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
  22
  23 ;; $Id: gtkaction.lisp,v 1.5 2005-04-23 16:48:52 espen Exp $
  24
  25
  26 (in-package "GTK")
  27
  28 ;;; Action
  29
  30 (defmethod initialize-instance ((action action) &key callback)
  31   (call-next-method)
  32   (when callback
  33     (apply #'signal-connect action 'activate (mklist callback))))
  34
  35 (defmethod action-accelerator ((action action))
  36   (object-data action 'accelerator))
  37
  38 (defbinding (action-is-sensitive-p "gtk_action_is_sensitive") () boolean
  39   (action action))
  40
  41 (defbinding (action-is-visible-p "gtk_action_is_visible") () boolean
  42   (action action))
  43
  44 (defbinding action-activate () nil
  45   (action action))
  46
  47
  48 ;;; Action Group
  49
  50 (defmethod initialize-instance ((action-group action-group) &rest initargs
  51                                 &key action actions)
  52   (declare (ignore action actions))
  53   (prog1
  54       (call-next-method)
  55     (initial-add action-group #'action-group-add-action
  56      initargs :action :actions)))
  57
  58 (defbinding action-group-get-action () action
  59   (action-group action-group)
  60   (name string))
  61
  62 (defbinding action-group-list-actions () (glist action)
  63   (action-group action-group))
  64
  65 (defbinding %action-group-add-action () nil
  66   (action-group action-group)
  67   (action action))
  68
  69 (defbinding %action-group-add-action-with-accel () nil
  70   (action-group action-group)
  71   (action action)
  72   (accelerator (or null string)))
  73
  74 (defun action-group-add-action (action-group action)
  75   (if (slot-boundp action 'accelerator)
  76       (%action-group-add-action-with-accel action-group action (action-accelerator action))
  77     (%action-group-add-action action-group action)))
  78
  79 (defbinding action-group-remove-action () nil
  80   (action-group action-group)
  81   (action action))
  82
  83
  84 ;;; Radio Action
  85
  86 (defmethod initialize-instance ((action radio-action) &key group)
  87   (call-next-method)
  88   (setf (slot-value action 'self) (sap-int (proxy-location action)))
  89   (when group
  90     (add-to-radio-group action group)))
  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 (defmethod add-to-radio-group ((action1 radio-action) (action2 radio-action))
 100   "Add ACTION1 to the group which ACTION2 belongs to."
 101   (%radio-action-set-group action1 (%radio-action-get-group action2)))
 102
 103 (defmethod activate-radio-widget ((action radio-action))
 104   (action-activate action))
 105
 106 (defmethod add-activate-callback ((action radio-action) function &key object after)
 107   (%add-activate-callback action 'activate function object after))
 108
 109 (defbinding (radio-action-get-current "gtk_radio_action_get_current_value")
 110     () radio-action
 111   "Returns the current active radio action in the group the give radio action belongs to."
 112   (radio-action radio-action))
 113
 114 (defun radio-action-get-current-value (action)
 115   (radio-value-action (radio-action-get-current action)))
 116
 117
 118
 119 ;;; Toggle Action
 120
 121 (defmethod initialize-instance ((action toggle-action) &rest initargs &key callback)
 122   (remf initargs :callback)
 123   (apply #'call-next-method action initargs)
 124   (when callback
 125     (destructuring-bind (function &key object after) (mklist callback)
 126       (signal-connect action 'activate
 127        (if object
 128            #'(lambda (object)
 129                (funcall function object (toggle-action-active-p action)))
 130          #'(lambda ()
 131              (funcall function (toggle-action-active-p action))))
 132        :object object :after after)))
 133   (when (toggle-action-active-p action)
 134     (action-activate action)))
 135
 136 (defbinding toggle-action-toggled () nil
 137   (toggle-action toggle-action))
 138
 139
 140 ;;; UI Manager
 141
 142 (defmethod initialize-instance ((ui-manager ui-manager) &rest initargs
 143                                 &key ui action-group)
 144   (declare (ignore ui action-group))
 145   (call-next-method)
 146   (mapc #'(lambda (action-group)
 147             (ui-manager-insert-action-group ui-manager action-group))
 148         (get-all initargs :action-group))
 149   (mapc #'(lambda (ui)
 150             (ui-manager-add-ui ui-manager ui))
 151         (get-all initargs :ui)))
 152
 153
 154 (defbinding ui-manager-insert-action-group
 155     (ui-manager action-group &optional (pos :end)) nil
 156   (ui-manager ui-manager)
 157   (action-group action-group)
 158   ((case pos
 159      (:first 0)
 160      (:end -1)
 161      (t pos)) int))
 162
 163 (defbinding ui-manager-remove-action-group () nil
 164   (ui-manager ui-manager)
 165   (action-group action-group))
 166
 167 (defbinding ui-manager-get-widget () widget
 168   (ui-manager ui-manager)
 169   (path string))
 170
 171 (defbinding ui-manager-get-toplevels () (glist widget)
 172   (ui-manager ui-manager)
 173   (types ui-manager-item-type))
 174
 175 (defbinding ui-manager-get-action () action
 176   (ui-manager ui-manager)
 177   (path string))
 178
 179 (defbinding %ui-manager-add-ui-from-string (ui-manager ui) int
 180   (ui-manager ui-manager)
 181   (ui string)
 182   ((length ui) int)
 183   (gerror pointer :out))
 184
 185 (defmethod ui-manager-add-ui ((ui-manager ui-manager) (ui-spec string))
 186   (let ((id (%ui-manager-add-ui-from-string ui-manager ui-spec)))
 187     (when (zerop id)
 188       (error "We need to handle GError in som way"))
 189     id))
 190
 191 (defbinding %ui-manager-add-ui-from-file () int
 192   (ui-manager ui-manager)
 193   (filename pathname)
 194   (gerror pointer :out))
 195
 196 (defmethod ui-manager-add-ui ((ui-manager ui-manager) (path pathname))
 197   (let ((id (%ui-manager-add-ui-from-file ui-manager path)))
 198     (when (zerop id)
 199       (error "We need to handle GError in som way"))
 200     id))
 201
 202 (defbinding %ui-manager-new-merge-id () unsigned-int
 203   (ui-manager ui-manager))
 204
 205 (defbinding %ui-manager-add-ui () nil
 206   (ui-manager ui-manager)
 207   (merge-id unsigned-int)
 208   (path string)
 209   (name string)
 210   (action (or null string))
 211   (type ui-manager-item-type)
 212   (top boolean))
 213
 214 (defvar *valid-ui-elements*
 215   '((:ui :menubar :toolbar :popup :accelerator)
 216     (:menubar :menuitem :separator :placeholder :menu)
 217     (:menu :menuitem :separator :placehoder :menu)
 218     (:popup :menuitem :separator :placehoder :menu)
 219     (:toolbar :toolitem :separator :placehoder)
 220     (:placeholder :menuitem :toolitem :separator :placeholder :menu)
 221     (:menuitem)
 222     (:toolitem)
 223     (:separator)
 224     (:accelerator)))
 225
 226 (defvar *anonymous-element-counter* 0)
 227 (internal *anonymous-element-counter*)
 228
 229 (defmethod ui-manager-add-ui ((ui-manager ui-manager) (ui-spec list))
 230   (let ((id (%ui-manager-new-merge-id ui-manager)))
 231     (labels
 232         ((parse-ui-spec (path ui-spec element)
 233            (loop
 234             for definition in ui-spec
 235             do (destructuring-bind (type &optional name &rest rest)
 236                    (mklist definition)
 237                  (cond
 238                   ((not (find type (cdr (assoc element *valid-ui-elements*))))
 239                    (ui-manager-remove-ui ui-manager id)
 240                    (error "~S not valid subelement in ~S" type element))
 241                   ((multiple-value-bind (action children)
 242                        (if (and rest (atom (first rest))
 243                                 (not (keywordp (first rest))))
 244                            (values (first rest) (rest rest))
 245                          (values name rest))
 246                      (%ui-manager-add-ui ui-manager
 247                       id (or path "/")
 248                       (or name (format nil "~A~D"
 249                                 (string-capitalize type)
 250                                 (incf *anonymous-element-counter*)))
 251                       action type nil)
 252                      (when children
 253                        (parse-ui-spec (concatenate 'string path "/" name)
 254                                       children type)))))))))
 255       (parse-ui-spec nil ui-spec :ui))
 256     id))
 257
 258 (defbinding ui-manager-remove-ui () nil
 259   (ui-manager ui-manager)
 260   (merge-id unsigned-int))
 261
 262 (defbinding ui-manager-get-ui () string
 263   (ui-manager ui-manager))
 264
 265 (defbinding ui-manager-ensure-update () nil
 266   (ui-manager ui-manager))