X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/8755b1a5d37f2f4b853c01f0d8b121ab9ee4093a..112ac1d33aa8f9b7f3d2f9542d15431f152b1d35:/gtk/gtkcontainer.lisp diff --git a/gtk/gtkcontainer.lisp b/gtk/gtkcontainer.lisp index 8a24bd0..2987297 100644 --- a/gtk/gtkcontainer.lisp +++ b/gtk/gtkcontainer.lisp @@ -1,30 +1,53 @@ -;; Common Lisp bindings for GTK+ v2.0 -;; Copyright (C) 2000 Espen S. Johnsen +;; Common Lisp bindings for GTK+ v2.x +;; Copyright 2000-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: gtkcontainer.lisp,v 1.11 2004-11-07 01:23:38 espen Exp $ +;; $Id: gtkcontainer.lisp,v 1.18 2005-04-23 16:48:52 espen Exp $ (in-package "GTK") - + (defmethod shared-initialize ((container container) names &rest initargs - &key child children child-args) - (declare (ignore child)) + &key child children child-args + (show-children nil show-children-p)) + (declare (ignore child children)) + (when show-children-p + (if (not show-children) + (setf (user-data container 'show-recursive-p) nil) + (signal-connect container 'show #'container-show-recursive + :object t :remove t))) + (call-next-method) - (dolist (child (append children (get-all initargs :child))) - (apply #'container-add container (append (mklist child) child-args)))) + (initial-add container + #'(lambda (container args) + (apply #'container-add container (append (mklist args) child-args))) + initargs :child :children)) + + +(defmethod compute-signal-function ((container container) signal function object) + (if (eq object :children) + #'(lambda (&rest args) + (mapc #'(lambda (child) + (apply function child (rest args))) + (container-children container))) + (call-next-method))) (defbinding %container-add () nil @@ -35,20 +58,19 @@ (defmethod container-add ((container container) (widget widget) &rest args) (%container-add container widget) (when args (setf - (slot-value widget 'child-slots) + (slot-value widget 'child-properties) (apply #'make-instance (gethash (class-of container) *container-to-child-class-mappings*) :parent container :child widget args)))) - (defbinding %container-remove () nil (container container) (widget widget)) (defmethod container-remove ((container container) (widget widget)) (%container-remove container widget) - (slot-makunbound widget 'child-slots)) + (slot-makunbound widget 'child-properties)) (defbinding %container-child-get-property () nil @@ -75,10 +97,17 @@ (defbinding %container-foreach (container callback-id) nil (callback-id unsigned-int)) (defun container-foreach (container function) - (let ((callback-id (register-callback-function function))) - (unwind-protect - (%container-foreach container callback-id) - (destroy-user-data callback-id)))) + (with-callback-function (id function) + (%container-foreach container id))) + +(defbinding %container-forall (container callback-id) nil + (container container) + ((callback %foreach-callback) pointer) + (callback-id unsigned-int)) + +(defun container-forall (container function) + (with-callback-function (id function) + (%container-forall container id))) (defun map-container (seqtype func container) (case seqtype @@ -102,31 +131,14 @@ (defun map-container (seqtype func container) (incf index))) seq)))) -(defmacro do-container ((var container &optional (result nil)) &body body) - (let ((continue (make-symbol "CONTINUE"))) - `(let ((,continue t)) - (container-foreach - ,container - #'(lambda (,var) - (when ,continue - (setq ,continue nil) - (block nil - ,@body - (setq ,continue t))))) - ,result))) - -;; (defbinding %container-get-children () (glist widget) -;; (container container)) - (defmethod container-children ((container container)) -;; (%container-get-children container) (map-container 'list #'identity container)) (defmethod (setf container-children) (children (container container)) (dolist (child (container-children container)) (container-remove container child)) (dolist (child children) - (container-add container child)) + (apply #'container-add container (mklist child))) children) (defun container-length (container) @@ -166,3 +178,16 @@ (defun (setf container-focus-chain) (focusable-widgets container) (if (null focusable-widgets) (%container-unset-focus-chain container) (%container-set-focus-chain container focusable-widgets))) + +(defgeneric container-show-recursive (container)) + +(defmethod container-show-recursive ((container container)) + "Recursively shows any child widgets except widgets explicit hidden during construction." + (labels ((recursive-show (widget) + (when (typep widget 'container) + (if (not (user-data-p widget 'show-recursive-p)) + (container-foreach widget #'recursive-show) + (unset-user-data widget 'show-recursive-p))) + (unless (widget-hidden-p widget) + (widget-show widget)))) + (container-foreach container #'recursive-show)))