X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/13955a62d70249e4995ec05a1eb6844849756460..72d9260f8258b525339c7241da0631ceaf9f3842:/gtk/gtkaction.lisp diff --git a/gtk/gtkaction.lisp b/gtk/gtkaction.lisp index 5282dfd..7db1f2f 100644 --- a/gtk/gtkaction.lisp +++ b/gtk/gtkaction.lisp @@ -1,33 +1,36 @@ -;; Common Lisp bindings for GTK+ v2.0 -;; Copyright (C) 1999-2001 Espen S. Johnsen +;; Common Lisp bindings for GTK+ v2.x +;; Copyright 2005 Espen S. Johnsen ;; -;; This library is free software; you can redistribute it and/or -;; modify it under the terms of the GNU Lesser General Public -;; License as published by the Free Software Foundation; either -;; version 2 of the License, or (at your option) any later version. +;; Permission is hereby granted, free of charge, to any person obtaining +;; a copy of this software and associated documentation files (the +;; "Software"), to deal in the Software without restriction, including +;; without limitation the rights to use, copy, modify, merge, publish, +;; distribute, sublicense, and/or sell copies of the Software, and to +;; permit persons to whom the Software is furnished to do so, subject to +;; the following conditions: ;; -;; This library is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; Lesser General Public License for more details. +;; The above copyright notice and this permission notice shall be +;; included in all copies or substantial portions of the Software. ;; -;; You should have received a copy of the GNU Lesser General Public -;; License along with this library; if not, write to the Free Software -;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -;; $Id: gtkaction.lisp,v 1.2 2004-12-17 00:13:33 espen Exp $ +;; $Id: gtkaction.lisp,v 1.13 2008-04-11 18:34:02 espen Exp $ (in-package "GTK") ;;; Action -(defmethod initialize-instance ((action action) &key accelerator) +(defmethod initialize-instance ((action action) &key callback) (call-next-method) - (setf (object-data action 'accelerator) accelerator)) - -(defmethod action-accelerator ((action action)) - (object-data action 'accelerator)) + (when callback + (apply #'signal-connect action 'activate (mklist callback)))) (defbinding (action-is-sensitive-p "gtk_action_is_sensitive") () boolean (action action)) @@ -46,7 +49,7 @@ (defmethod initialize-instance ((action-group action-group) &rest initargs (declare (ignore action actions)) (prog1 (call-next-method) - (initial-add action-group #'action-group-add-action + (initial-add action-group #'action-group-add-action initargs :action :actions))) (defbinding action-group-get-action () action @@ -66,11 +69,9 @@ (defbinding %action-group-add-action-with-accel () nil (accelerator (or null string))) (defun action-group-add-action (action-group action) - (multiple-value-bind (accelerator accelerator-p) - (object-data action 'accelerator) - (if accelerator-p - (%action-group-add-action-with-accel action-group action accelerator) - (%action-group-add-action action-group action)))) + (if (slot-boundp action 'accelerator) + (%action-group-add-action-with-accel action-group action (action-accelerator action)) + (%action-group-add-action action-group action))) (defbinding action-group-remove-action () nil (action-group action-group) @@ -79,43 +80,61 @@ (defbinding action-group-remove-action () nil ;;; Radio Action -(defmethod initialize-instance ((action radio-action) &key group value) +(defmethod initialize-instance ((action radio-action) &key group) (call-next-method) - (setf (slot-value action '%value) (system:sap-int (proxy-location action))) - (setf (object-data action 'radio-action-value) value) + (setf (slot-value action 'self) (pointer-address (foreign-location action))) (when group - (radio-action-add-to-group action group))) - -(defmethod radio-value-action ((action radio-action)) - (object-data action 'radio-action-value)) + (add-to-radio-group action group))) (defbinding %radio-action-get-group () pointer (radio-action radio-action)) (defbinding %radio-action-set-group () nil - (radio-button radio-button) + (radio-action radio-action) (group pointer)) -(defun radio-action-add-to-group (action1 action2) +(defmethod add-to-radio-group ((action1 radio-action) (action2 radio-action)) "Add ACTION1 to the group which ACTION2 belongs to." (%radio-action-set-group action1 (%radio-action-get-group action2))) +(defmethod activate-radio-widget ((action radio-action)) + (action-activate action)) + +(defmethod add-activate-callback ((action radio-action) function &key object after) + (%add-activate-callback action 'activate function object after)) + (defbinding (radio-action-get-current "gtk_radio_action_get_current_value") () radio-action + "Returns the current active radio action in the group the give radio action belongs to." (radio-action radio-action)) (defun radio-action-get-current-value (action) - (radio-value-action (radio-action-get-current action))) + (radio-action-value (radio-action-get-current action))) ;;; Toggle Action +(defmethod initialize-instance ((action toggle-action) &rest initargs &key callback #?-(pkg-exists-p "gtk+-2.0" :atleast-version "2.10.0")active) + (remf initargs :callback) + (apply #'call-next-method action initargs) + (when callback + (destructuring-bind (function &key object after) (mklist callback) + (signal-connect action 'activate + (if object + #'(lambda (object) + (funcall function object (toggle-action-active-p action))) + #'(lambda () + (funcall function (toggle-action-active-p action)))) + :object object :after after))) + #?-(pkg-exists-p "gtk+-2.0" :atleast-version "2.10.0") + (when active + (action-activate action))) + (defbinding toggle-action-toggled () nil (toggle-action toggle-action)) - ;;; UI Manager (defmethod initialize-instance ((ui-manager ui-manager) &rest initargs @@ -159,24 +178,20 @@ (defbinding %ui-manager-add-ui-from-string (ui-manager ui) int (ui-manager ui-manager) (ui string) ((length ui) int) - (gerror pointer :out)) + (gerror gerror-signal :out)) + +(defgeneric ui-manager-add-ui (ui-manager ui-spec)) (defmethod ui-manager-add-ui ((ui-manager ui-manager) (ui-spec string)) - (let ((id (%ui-manager-add-ui-from-string ui-manager ui-spec))) - (when (zerop id) - (error "We need to handle GError in som way")) - id)) + (%ui-manager-add-ui-from-string ui-manager ui-spec)) (defbinding %ui-manager-add-ui-from-file () int (ui-manager ui-manager) (filename pathname) - (gerror pointer :out)) + (gerror gerror-signal :out)) (defmethod ui-manager-add-ui ((ui-manager ui-manager) (path pathname)) - (let ((id (%ui-manager-add-ui-from-file ui-manager path))) - (when (zerop id) - (error "We need to handle GError in som way")) - id)) + (%ui-manager-add-ui-from-file ui-manager path)) (defbinding %ui-manager-new-merge-id () unsigned-int (ui-manager ui-manager)) @@ -193,15 +208,18 @@ (defbinding %ui-manager-add-ui () nil (defvar *valid-ui-elements* '((:ui :menubar :toolbar :popup :accelerator) (:menubar :menuitem :separator :placeholder :menu) - (:menu :menuitem :separator :placehoder :menu) - (:popup :menuitem :separator :placehoder :menu) - (:toolbar :toolitem :separator :placehoder) + (:menu :menuitem :separator :placeholder :menu) + (:popup :menuitem :separator :placeholder :menu) + (:toolbar :toolitem :separator :placeholder) (:placeholder :menuitem :toolitem :separator :placeholder :menu) (:menuitem) (:toolitem) (:separator) (:accelerator))) +(defvar *anonymous-element-counter* 0) +(internal *anonymous-element-counter*) + (defmethod ui-manager-add-ui ((ui-manager ui-manager) (ui-spec list)) (let ((id (%ui-manager-new-merge-id ui-manager))) (labels @@ -219,7 +237,12 @@ (defmethod ui-manager-add-ui ((ui-manager ui-manager) (ui-spec list)) (not (keywordp (first rest)))) (values (first rest) (rest rest)) (values name rest)) - (%ui-manager-add-ui ui-manager id (or path "/") name action type nil) + (%ui-manager-add-ui ui-manager + id (or path "/") + (or name (format nil "~A~D" + (string-capitalize type) + (incf *anonymous-element-counter*))) + action type nil) (when children (parse-ui-spec (concatenate 'string path "/" name) children type)))))))))