X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/73572c12ccd49c661d06287903bfa725f5fd93a5..142c1cf69cb50380e98fbaea67a7e62d97a4ae4c:/gtk/gtkaction.lisp diff --git a/gtk/gtkaction.lisp b/gtk/gtkaction.lisp index ae5043b..5860e2b 100644 --- a/gtk/gtkaction.lisp +++ b/gtk/gtkaction.lisp @@ -1,30 +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.3 2005-02-03 23:09:09 espen Exp $ +;; $Id: gtkaction.lisp,v 1.5 2005-04-23 16:48:52 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)) + (when callback + (apply #'signal-connect action 'activate (mklist callback)))) (defmethod action-accelerator ((action action)) (object-data action 'accelerator)) @@ -46,7 +52,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 +72,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,15 +83,11 @@ (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) (sap-int (proxy-location action))) - (setf (object-data action 'radio-action-value) value) + (setf (slot-value action 'self) (sap-int (proxy-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)) @@ -96,12 +96,19 @@ (defbinding %radio-action-set-group () nil (radio-button radio-button) (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) @@ -111,11 +118,25 @@ (defun radio-action-get-current-value (action) ;;; Toggle Action +(defmethod initialize-instance ((action toggle-action) &rest initargs &key callback) + (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))) + (when (toggle-action-active-p action) + (action-activate action))) + (defbinding toggle-action-toggled () nil (toggle-action toggle-action)) - ;;; UI Manager (defmethod initialize-instance ((ui-manager ui-manager) &rest initargs @@ -202,6 +223,9 @@ (defvar *valid-ui-elements* (: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 +243,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)))))))))