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.1 2004-12-04 18:03:21 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   (call-next-method)
  48   (flet ((add-action (action)
  49            (action-group-add-action action-group action)))
  50     (loop
  51      as (initarg value . rest) = initargs then rest
  52      do (case initarg
  53           (:action (add-action value))
  54           (:actions (mapc #'add-action value)))
  55      while rest)))
  56
  57 (defbinding action-group-get-action () action
  58   (action-group action-group)
  59   (name string))
  60
  61 (defbinding action-group-list-actions () (glist action)
  62   (action-group action-group))
  63
  64 (defbinding %action-group-add-action () nil
  65   (action-group action-group)
  66   (action action))
  67
  68 (defbinding %action-group-add-action-with-accel () nil
  69   (action-group action-group)
  70   (action action)
  71   (accelerator (or null string)))
  72
  73 (defun action-group-add-action (action-group action)
  74   (multiple-value-bind (accelerator accelerator-p)
  75       (object-data action 'accelerator)
  76     (if accelerator-p
  77         (%action-group-add-action-with-accel action-group action accelerator)
  78       (%action-group-add-action action-group action))))
  79
  80 (defbinding action-group-remove-action () nil
  81   (action-group action-group)
  82   (action action))
  83
  84
  85 ;;; Radio Action
  86
  87 (defmethod initialize-instance ((action radio-action) &key group value)
  88   (call-next-method)
  89   (setf (slot-value action '%value) (system:sap-int (proxy-location action)))
  90   (setf (object-data action 'radio-action-value) value)
  91   (when group
  92     (radio-action-add-to-group action group)))
  93
  94 (defmethod radio-value-action ((action radio-action))
  95   (object-data action 'radio-action-value))
  96
  97 (defbinding %radio-action-get-group () pointer
  98   (radio-action radio-action))
  99
 100 (defbinding %radio-action-set-group () nil
 101   (radio-button radio-button)
 102   (group pointer))
 103
 104 (defun radio-action-add-to-group (action1 action2)
 105   "Add ACTION1 to the group which ACTION2 belongs to."
 106   (%radio-action-set-group action1 (%radio-action-get-group action2)))
 107
 108 (defbinding (radio-action-get-current "gtk_radio_action_get_current_value")
 109     () radio-action
 110   (radio-action radio-action))
 111
 112 (defun radio-action-get-current-value (action)
 113   (radio-value-action (radio-action-get-current action)))
 114
 115
 116
 117 ;;; Toggle Action
 118
 119 (defbinding toggle-action-toggled () nil
 120   (toggle-action toggle-action))
 121
 122
 123
 124 ;;; UI Manager
 125
 126 (defmethod initialize-instance ((ui-manager ui-manager) &rest initargs
 127                                 &key ui action-group)
 128   (declare (ignore ui action-group))
 129   (call-next-method)
 130   (mapc #'(lambda (action-group)
 131             (ui-manager-insert-action-group ui-manager action-group))
 132         (get-all initargs :action-group))
 133   (mapc #'(lambda (ui)
 134             (ui-manager-add-ui ui-manager ui))
 135         (get-all initargs :ui)))
 136
 137
 138 (defbinding ui-manager-insert-action-group
 139     (ui-manager action-group &optional (pos :end)) nil
 140   (ui-manager ui-manager)
 141   (action-group action-group)
 142   ((case pos
 143      (:first 0)
 144      (:end -1)
 145      (t pos)) int))
 146
 147 (defbinding ui-manager-remove-action-group () nil
 148   (ui-manager ui-manager)
 149   (action-group action-group))
 150
 151 (defbinding ui-manager-get-widget () widget
 152   (ui-manager ui-manager)
 153   (path string))
 154
 155 (defbinding ui-manager-get-toplevels () (glist widget)
 156   (ui-manager ui-manager)
 157   (types ui-manager-item-type))
 158
 159 (defbinding ui-manager-get-action () action
 160   (ui-manager ui-manager)
 161   (path string))
 162
 163 (defbinding %ui-manager-add-ui-from-string (ui-manager ui) int
 164   (ui-manager ui-manager)
 165   (ui string)
 166   ((length ui) int)
 167   (gerror pointer :out))
 168
 169 (defmethod ui-manager-add-ui ((ui-manager ui-manager) (ui-spec string))
 170   (let ((id (%ui-manager-add-ui-from-string ui-manager ui-spec)))
 171     (when (zerop id)
 172       (error "We need to handle GError in som way"))
 173     id))
 174
 175 (defbinding %ui-manager-add-ui-from-file () int
 176   (ui-manager ui-manager)
 177   (filename pathname)
 178   (gerror pointer :out))
 179
 180 (defmethod ui-manager-add-ui ((ui-manager ui-manager) (path pathname))
 181   (let ((id (%ui-manager-add-ui-from-file ui-manager path)))
 182     (when (zerop id)
 183       (error "We need to handle GError in som way"))
 184     id))
 185
 186 (defbinding %ui-manager-new-merge-id () unsigned-int
 187   (ui-manager ui-manager))
 188
 189 (defbinding %ui-manager-add-ui () nil
 190   (ui-manager ui-manager)
 191   (merge-id unsigned-int)
 192   (path string)
 193   (name string)
 194   (action (or null string))
 195   (type ui-manager-item-type)
 196   (top boolean))
 197
 198 (defvar *valid-ui-elements*
 199   '((:ui :menubar :toolbar :popup :accelerator)
 200     (:menubar :menuitem :separator :placeholder :menu)
 201     (:menu :menuitem :separator :placehoder :menu)
 202     (:popup :menuitem :separator :placehoder :menu)
 203     (:toolbar :toolitem :separator :placehoder)
 204     (:placeholder :menuitem :toolitem :separator :placeholder :menu)
 205     (:menuitem)
 206     (:toolitem)
 207     (:separator)
 208     (:accelerator)))
 209
 210 (defmethod ui-manager-add-ui ((ui-manager ui-manager) (ui-spec list))
 211   (let ((id (%ui-manager-new-merge-id ui-manager)))
 212     (labels
 213         ((parse-ui-spec (path ui-spec element)
 214            (loop
 215             for definition in ui-spec
 216             do (destructuring-bind (type &optional name &rest rest)
 217                    (mklist definition)
 218                  (cond
 219                   ((not (find type (cdr (assoc element *valid-ui-elements*))))
 220                    (ui-manager-remove-ui ui-manager id)
 221                    (error "~S not valid subelement in ~S" type element))
 222                   ((multiple-value-bind (action children)
 223                        (if (and rest (atom (first rest))
 224                                 (not (keywordp (first rest))))
 225                            (values (first rest) (rest rest))
 226                          (values name rest))
 227                      (%ui-manager-add-ui ui-manager id (or path "/") name action type nil)
 228                      (when children
 229                        (parse-ui-spec (concatenate 'string path "/" name)
 230                                       children type)))))))))
 231       (parse-ui-spec nil ui-spec :ui))
 232     id))
 233
 234 (defbinding ui-manager-remove-ui () nil
 235   (ui-manager ui-manager)
 236   (merge-id unsigned-int))
 237
 238 (defbinding ui-manager-get-ui () string
 239   (ui-manager ui-manager))
 240
 241 (defbinding ui-manager-ensure-update () nil
 242   (ui-manager ui-manager))