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