X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/8e947895f8a220533159369999c881cad2fe37dd..b6d4ac86c7f32c64e5a0debea5ad93f2f00672e7:/gtk/gtkwidget.lisp diff --git a/gtk/gtkwidget.lisp b/gtk/gtkwidget.lisp index 7f9aa5c..fc2e7bf 100644 --- a/gtk/gtkwidget.lisp +++ b/gtk/gtkwidget.lisp @@ -1,41 +1,59 @@ -;; Common Lisp bindings for GTK+ v2.0 -;; Copyright (C) 2000-2002 Espen S. Johnsen +;; Common Lisp bindings for GTK+ v2.x +;; Copyright 2000-2006 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: gtkwidget.lisp,v 1.15 2005-01-12 13:51:02 espen Exp $ +;; $Id: gtkwidget.lisp,v 1.23 2006-04-26 12:11:21 espen Exp $ (in-package "GTK") -(defmethod shared-initialize ((widget widget) names &rest initargs &key parent) - (remf initargs :parent) - (prog1 - (apply #'call-next-method widget names initargs) - (when parent - (when (slot-boundp widget 'parent) - (container-remove (widget-parent widget) widget)) - (let ((parent-widget (first (mklist parent))) - (args (rest (mklist parent)))) - (apply #'container-add parent-widget widget args))))) +#-debug-ref-counting +(defmethod print-object ((widget widget) stream) + (if (and + (proxy-valid-p widget) + (slot-boundp widget 'name) (not (zerop (length (widget-name widget))))) + (print-unreadable-object (widget stream :type t :identity nil) + (format stream "~S at 0x~X" + (widget-name widget) (pointer-address (foreign-location widget)))) + (call-next-method))) -(defmethod shared-initialize :after ((widget widget) names &rest initargs - &key show-all all-visible) - (declare (ignore initargs names)) - (when (or all-visible show-all) - (widget-show-all widget))) +(defmethod shared-initialize ((widget widget) names &key (visible nil visible-p)) + (declare (ignore names)) + (when (and visible-p (not visible)) ; widget explicit set as not visible + (setf (user-data widget 'hidden-p) t) + (signal-connect widget 'show + #'(lambda () + (unset-user-data widget 'hidden-p)) + :remove t)) + (call-next-method)) + +(defmethod shared-initialize :after ((widget widget) names &key parent visible) + (declare (ignore names)) + (when visible + (widget-show widget)) + (when parent + (when (slot-boundp widget 'parent) + (container-remove (widget-parent widget) widget)) + (destructuring-bind (parent &rest args) (mklist parent) + (apply #'container-add parent widget args)))) (defmethod slot-unbound ((class gobject-class) (object widget) (slot (eql 'child-properties))) @@ -48,15 +66,10 @@ (defmethod slot-unbound ((class gobject-class) (object widget) :parent parent :child object)))) ((call-next-method)))) -(defmethod slot-boundp-using-class ((class gobject-class) (object widget) slot) - (or - (and - (eq (slot-definition-name slot) 'child-properties) - (slot-boundp object 'parent)) - (call-next-method))) -(defmethod create-callback-function ((widget widget) function arg1) - (if (eq arg1 :parent) +(defmethod compute-signal-function ((widget widget) signal function object) + (declare (ignore signal)) + (if (eq object :parent) #'(lambda (&rest args) (if (slot-boundp widget 'parent) (apply function (widget-parent widget) (rest args)) @@ -101,6 +114,10 @@ (defbinding widget-show-now () nil (defbinding widget-hide () nil (widget widget)) +(defun widget-hidden-p (widget) + "Return T if WIDGET has been explicit hidden during construction." + (user-data widget 'hidden-p)) + (defbinding widget-show-all () nil (widget widget)) @@ -131,12 +148,12 @@ (defbinding widget-queue-resize-no-redraw () nil (defbinding widget-size-request (widget &optional (requisition (make-instance 'requisition))) nil (widget widget) - (requisition requisition :return)) + (requisition requisition :in/return)) (defbinding widget-get-child-requisition (widget &optional (requisition (make-instance 'requisition))) nil (widget widget) - (requisition requisition :return)) + (requisition requisition :in/return)) (defbinding widget-size-allocate () nil (widget widget) @@ -145,7 +162,7 @@ (defbinding widget-size-allocate () nil (defbinding widget-add-accelerator (widget signal accel-group key modifiers flags) nil (widget widget) - ((name-to-string signal) string) + ((signal-name-to-string signal) string) (accel-group accel-group) ((gdk:keyval-from-name key) unsigned-int) (modifiers gdk:modifier-type) @@ -318,10 +335,12 @@ (defbinding widget-modify-base () nil (state state-type) (color gdk:color)) -(defbinding widget-modify-font () nil +(defbinding widget-modify-font (widget font-desc) nil (widget widget) - (state state-type) - (font-desc pango:font-description)) + ((etypecase font-desc + (pango:font-description font-desc) + (string (pango:font-description-from-string font-desc))) + pango:font-description)) (defbinding widget-create-pango-context () pango:context (widget widget)) @@ -471,8 +490,12 @@ (defbinding get-event-widget () widget (event gdk:event)) (defun (setf widget-cursor) (cursor-type widget) - (let ((cursor (make-instance 'gdk:cursor :type cursor-type))) - (gdk:window-set-cursor (widget-window widget) cursor))) + (warn "(SETF WIDGET-CURSOR) is deprecated, use WIDGET-SET-CURSOR instead") + (widget-set-cursor widget cursor-type)) + +(defun widget-set-cursor (widget cursor &rest args) + (gdk:window-set-cursor (widget-window widget) + (apply #'gdk:ensure-cursor cursor args))) (defbinding %widget-get-parent-window () gdk:window (widget widget))