X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/1047e159d403df191a35ed684e3c80517fbf3807..3494da2a2fe7551426d4fbdbce7dc21200423772:/gtk/gtkwidget.lisp diff --git a/gtk/gtkwidget.lisp b/gtk/gtkwidget.lisp index e04d7f7..100b0e2 100644 --- a/gtk/gtkwidget.lisp +++ b/gtk/gtkwidget.lisp @@ -1,71 +1,107 @@ -;; 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.9 2004-10-31 12:05:52 espen Exp $ +;; $Id: gtkwidget.lisp,v 1.30 2008-04-11 18:42:40 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 - (let ((old-parent (widget-parent widget)) - (parent (first (mklist parent))) - (args (rest (mklist parent)))) - (when old-parent - (container-remove old-parent widget)) - (apply #'container-add parent widget args))))) - -(defmethod shared-initialize :after ((widget widget) names &rest initargs - &key show-all) - (declare (ignore initargs names)) - (when show-all - (widget-show-all widget))) - - -(defmethod slot-unbound ((class gobject-class) (object widget) slot) +#-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 ((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))) (cond - ((and (eq slot 'child-slots) (slot-value object 'parent)) - (with-slots (parent child-slots) object - (setf - child-slots - (make-instance - (gethash (class-of parent) *container-to-child-class-mappings*) + ((slot-boundp object 'parent) + (with-slots (parent child-properties) object + (setf child-properties + (make-instance (find-child-class (class-of parent)) :parent parent :child object)))) - (t (call-next-method)))) - - -(defun child-slot-value (widget slot) - (slot-value (widget-child-slots widget) slot)) - -(defun (setf child-slot-value) (value widget slot) - (setf (slot-value (widget-child-slots widget) slot) value)) - -(defmacro with-child-slots (slots widget &body body) - `(with-slots ,slots (widget-child-slots ,widget) + ((call-next-method)))) + + +(defparameter *widget-display-as-default-in-signal-handler-p* t) + +(defmethod compute-signal-function ((widget widget) signal function object args) + (let ((wrapper + (if (eq object :parent) + #'(lambda (&rest emission-args) + (let ((all-args (nconc (rest emission-args) args))) + (if (slot-boundp widget 'parent) + (apply function (widget-parent widget) all-args) + ;; Delay until parent is set + (signal-connect widget 'parent-set + #'(lambda (old-parent) + (declare (ignore old-parent)) + (apply #'signal-emit widget signal (rest emission-args))) + :remove t)))) + (call-next-method)))) + (if *widget-display-as-default-in-signal-handler-p* + #'(lambda (&rest args) + (let ((display (when (slot-boundp widget 'window) + (gdk:drawable-display (widget-window widget))))) + (gdk:with-default-display (display) + (apply wrapper args)))) + wrapper))) + + + +(defun child-property-value (widget slot) + (slot-value (widget-child-properties widget) slot)) + +(defun (setf child-property-value) (value widget slot) + (setf (slot-value (widget-child-properties widget) slot) value)) + +(defmacro with-child-properties (slots widget &body body) + `(with-slots ,slots (widget-child-properties ,widget) ,@body)) -(defmacro widget-destroyed (place) - `(setf ,place nil)) - - ;;; Bindings (defbinding widget-destroy () nil @@ -83,6 +119,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)) @@ -107,23 +147,27 @@ (defbinding widget-queue-draw () nil (defbinding widget-queue-resize () nil (widget widget)) -(defbinding widget-size-request () nil +(defbinding widget-queue-resize-no-redraw () nil + (widget widget)) + +(defbinding widget-size-request + (widget &optional (requisition (make-instance 'requisition))) nil (widget widget) - (requisition requisition)) + (requisition requisition :in/return)) -(defbinding widget-get-child-requisition () nil +(defbinding widget-get-child-requisition + (widget &optional (requisition (make-instance 'requisition))) nil (widget widget) - (requisition requisition)) + (requisition requisition :in/return)) (defbinding widget-size-allocate () nil (widget widget) (allocation allocation)) - (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) @@ -136,13 +180,19 @@ (defbinding widget-remove-accelerator ((gdk:keyval-from-name key) unsigned-int) (modifiers gdk:modifier-type)) -(defbinding (widget-set-accelerator-path "gtk_widget_set_accel_path") () nil +(defbinding widget-set-accel-path () nil (widget widget) (accel-path string) (accel-group accel-group)) - -(defbinding widget-event () int +(defbinding widget-list-accel-closures () (glist pointer) + (widget widget)) + +(defbinding widget-can-activate-accel-p () boolean + (widget widget) + (signal-id unsigned-int)) + +(defbinding widget-event () boolean (widget widget) (event gdk:event)) @@ -156,8 +206,7 @@ (defbinding widget-reparent () nil (defbinding %widget-intersect () boolean (widget widget) (area gdk:rectangle) - (intersection pointer)) - + (intersection (or null gdk:rectangle))) (defun widget-intersection (widget area) (let ((intersection (make-instance 'gdk:rectangle))) @@ -165,10 +214,7 @@ (defun widget-intersection (widget area) intersection))) (defun widget-intersect-p (widget area) - (%widget-intersect widget area (make-pointer 0))) - -(defbinding (widget-is-focus-p "gtk_widget_is_focus") () boolean - (widget widget)) + (%widget-intersect widget area nil)) (defbinding widget-grab-focus () nil (widget widget)) @@ -192,7 +238,7 @@ (defbinding widget-get-pointer () nil (x int :out) (y int :out)) -(defbinding (widget-is-ancestor-p "gtk_widget_is_ancestor") () boolean +(defbinding widget-is-ancestor-p () boolean (widget widget) (ancestor widget)) @@ -204,7 +250,7 @@ (defbinding widget-translate-coordinates () boolean (defun widget-hide-on-delete (widget) "Utility function; intended to be connected to the DELETE-EVENT -signal on a GtkWindow. The function calls WIDGET-HIDE on its +signal on a WINDOW. The function calls WIDGET-HIDE on its argument, then returns T. If connected to DELETE-EVENT, the result is that clicking the close button for a window (on the window frame, top right corner usually) will hide but not destroy the @@ -224,51 +270,103 @@ (defbinding widget-push-colormap () nil (defbinding widget-pop-colormap () nil) -(defbinding widget-set-default-colormap () nil +(defbinding %widget-set-default-colormap () nil (colormap gdk:colormap)) -(defbinding widget-get-default-style () style) +(defun (setf widget-default-colormap) (colormap) + (%widget-set-default-colormap colormap) + colormap) + +(defbinding (widget-default-style "gtk_widget_get_default_style") () style) -(defbinding widget-get-default-colormap () gdk:colormap) +(defbinding (widget-default-colromap "gtk_widget_get_default_colormap") + () gdk:colormap) -(defbinding widget-get-default-visual () gdk:visual) +(defbinding (widget-default-visual "gtk_widget_get_default_visual") + () gdk:visual) -(defbinding widget-get-default-direction () text-direction) +(defbinding (widget-default-direction "gtk_widget_get_default_direction") + () text-direction) -(defbinding widget-set-default-direction () nil - (direction text-direction)) +(defbinding %widget-set-default-direction () nil + (direction text-direction)) + +(defun (setf widget-default-direction) (direction) + (%widget-set-default-direction direction) + direction) (defbinding widget-shape-combine-mask () nil (widget widget) - (shape-mask gdk:bitmap) + (shape-mask (or null gdk:bitmap)) (x-offset int) (y-offset int)) -(defbinding widget-path () nil - (widget widget) - (path-length int :out) - (path string :out) - (reverse-path string :out)) +(defun widget-path (widget) + (let ((subpath (list (if (and + (slot-boundp widget 'name) + (not (zerop (length (widget-name widget))))) + (widget-name widget) + (type-of widget))))) + (if (slot-boundp widget 'parent) + (nconc (widget-path (widget-parent widget)) subpath) + subpath))) + +(defun widget-class-path (widget) + (let ((subpath (list (type-of widget)))) + (if (slot-boundp widget 'parent) + (nconc (widget-class-path (widget-parent widget)) subpath) + subpath))) + + +(defun widget-path-lookup (path &optional (root (nreverse (window-list-toplevels))) (error-p t)) + (let ((component (first path))) + (loop + for widget in (mklist root) + do (when (or + (and + (stringp component) (slot-boundp widget 'name) + (string= component (widget-name widget))) + (and + (symbolp component) (typep widget component))) + (cond + ((endp (rest path)) (return widget)) + ((typep widget 'container) + (let ((descendant (widget-path-lookup (rest path) (container-children widget) nil))) + (when descendant + (return descendant)))))))) + (when error-p + (error "Widget not found: ~A" path))) + + +(defun widget-find (name &optional (root (nreverse (window-list-toplevels))) (error-p t)) + "Search for a widget with the given name. ROOT should be a container +widget or a list of containers." + (loop + for widget in (mklist root) + do (cond + ((and (slot-boundp widget 'name) (string= name (widget-name widget))) + (return-from widget-find widget)) + ((typep widget 'container) + (let ((descendant (widget-find name (container-children widget) nil))) + (when descendant + (return-from widget-find descendant)))))) + (when error-p + (error "Widget not found: ~A" name))) -(defbinding widget-class-path () nil - (widget widget) - (path-length int :out) - (path string :out) - (reverse-path string :out)) (defbinding widget-modify-style () nil (widget widget) (style rc-style)) -(defbinding widget-modify-style () rc-style +(defbinding widget-get-modifier-style () rc-style (widget widget)) -(defbinding (widget-modify-foreground "gtk_widget_modify_fg") () nil +(defbinding widget-modify-fg () nil (widget widget) (state state-type) (color gdk:color)) -(defbinding (widget-modify-background "gtk_widget_modify_bg") () nil +(defbinding widget-modify-bg () nil (widget widget) (state state-type) (color gdk:color)) @@ -283,10 +381,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)) @@ -298,11 +398,12 @@ (defbinding widget-create-pango-layout (widget &optional text) pango:layout (widget widget) (text (or string null))) -(defbinding widget-render-icon () gdk:pixbuf +(defbinding widget-render-icon (widget stock-id &optional size detail) + gdk:pixbuf (widget widget) (stock-id string) - (size icon-size) - (detail string)) + ((or size -1) (or icon-size int)) + (detail (or null string))) (defbinding widget-push-composite-child () nil) @@ -319,27 +420,49 @@ (defbinding widget-set-double-buffered () nil (widget widget) (double-buffered boolean)) -(defbinding widget-set-redraw-on-allocate () nil - (widget widget) - (redraw-on-allocate boolean)) +;; (defbinding widget-set-redraw-on-allocate () nil +;; (widget widget) +;; (redraw-on-allocate boolean)) (defbinding widget-set-scroll-adjustments () boolean (widget widget) - (hadjustment adjustment) - (vadjustment adjustment)) + (hadjustment (or null adjustment)) + (vadjustment (or null adjustment))) (defbinding widget-mnemonic-activate () boolean (widget widget) (group-cycling boolean)) +(defbinding widget-class-find-style-property (class name) param + ((type-class-peek class) pointer) + (name string)) + +(defbinding widget-class-list-style-properties (class) + (vector (copy-of param) n-properties) + ((type-class-peek class) pointer) + (n-properties unsigned-int :out)) + (defbinding widget-region-intersect () pointer ;gdk:region (widget widget) (region pointer)) ;gdk:region)) -(defbinding widget-send-expose () int +(defbinding widget-send-expose () boolean (widget widget) (event gdk:event)) +(defbinding %widget-style-get-property () nil + (widget widget) + (name string) + (value gvalue)) + +(defun style-property-value (widget style) + (let* ((name (string-downcase style)) + (param (widget-class-find-style-property (class-of widget) name))) + (if (not param) + (error "~A has no such style property: ~A" widget style) + (with-gvalue (gvalue (param-value-type param)) + (%widget-style-get-property widget (string-downcase style) gvalue))))) + (defbinding widget-get-accessible () atk:object (widget widget)) @@ -354,6 +477,22 @@ (defbinding widget-child-notify () nil (defbinding widget-freeze-child-notify () nil (widget widget)) +(defbinding widget-get-clipboard () clipboard + (widget widget) + (selection int #|gdk:atom|#)) + +(defbinding widget-get-display () gdk:display + (widget widget)) + +(defbinding widget-get-root-window () gdk:window + (widget widget)) + +(defbinding widget-get-screen () gdk:screen + (widget widget)) + +(defbinding widget-has-screen-p () boolean + (widget widget)) + (defbinding %widget-get-size-request () nil (widget widget) (width int :out) @@ -361,7 +500,7 @@ (defbinding %widget-get-size-request () nil (defun widget-get-size-request (widget) (multiple-value-bind (width height) (%widget-get-size-request widget) - (values (unless (= width -1) width) (unless (= height -1) height)))) + (values (unless (= width -1) width) (unless (= height -1) height)))) (defbinding widget-set-size-request (widget width height) nil (widget widget) @@ -371,12 +510,35 @@ (defbinding widget-set-size-request (widget width height) nil (defbinding widget-thaw-child-notify () nil (widget widget)) +(defbinding widget-list-mnemonic-labels () (glist widget) + (widget widget)) + +(defbinding widget-add-mnemonic-label () nil + (widget widget) + (label widget)) + +(defbinding widget-remove-mnemonic-label () nil + (widget widget) + (label widget)) + ;;; Additional bindings and functions -(defbinding widget-mapped-p () boolean +(defbinding %widget-flags () int (widget widget)) +(defun widget-flags (widget) + (let ((flags (%widget-flags widget))) + (nconc + (int-to-object-flags flags) + (int-to-widget-flags flags)))) + +(defun widget-mapped-p (widget) + (find :mapped (widget-flags widget))) + +(defun widget-realized-p (widget) + (find :realized (widget-flags widget))) + (defbinding widget-get-size-allocation () nil (widget widget) (width int :out) @@ -386,5 +548,16 @@ (defbinding get-event-widget () widget (event gdk:event)) (defun (setf widget-cursor) (cursor-type widget) - (let ((cursor (make-instance '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)) + +(defun %widget-parent-window (widget) + (when (slot-boundp widget 'parent) + (%widget-get-parent-window widget)))