X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/560af5c515eb5b6206040a9334de4254d2650147..62f128081bd450f55d7e4ffd6602fb518f8ea304:/gtk/gtkwidget.lisp diff --git a/gtk/gtkwidget.lisp b/gtk/gtkwidget.lisp index 8d18573..7f9aa5c 100644 --- a/gtk/gtkwidget.lisp +++ b/gtk/gtkwidget.lisp @@ -1,5 +1,5 @@ ;; Common Lisp bindings for GTK+ v2.0 -;; Copyright (C) 2000 Espen S. Johnsen +;; Copyright (C) 2000-2002 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 @@ -15,208 +15,134 @@ ;; License along with this library; if not, write to the Free Software ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -;; $Id: gtkwidget.lisp,v 1.1 2000-08-14 16:45:02 espen Exp $ +;; $Id: gtkwidget.lisp,v 1.15 2005-01-12 13:51:02 espen Exp $ (in-package "GTK") -(eval-when (:compile-toplevel :load-toplevel :execute) - (defclass widget (object) - ((child-slots - :allocation :instance - :accessor widget-child-slots - :type container-child) - (name - :allocation :arg - :accessor widget-name - :initarg :name - :type string) - (parent - :allocation :arg - :accessor widget-parent -; :initarg :parent - :type container) - (x - :allocation :arg - :accessor widget-x-position - :initarg :x - :type int) - (y - :allocation :arg - :accessor widget-y-position - :initarg :y - :type int) - (width - :allocation :arg - :accessor widget-width - :initarg :width - :type int) - (height - :allocation :arg - :accessor widget-height - :initarg :height - :type int) - (visible - :allocation :arg - :accessor widget-visible-p - :initarg :visible - :type boolean) - (sensitive - :allocation :arg - :accessor widget-sensitive-p - :initarg :sensitive - :type boolean) - (app-paintable - :allocation :arg - :reader widget-app-paintable-p -; :access :read-only - :type boolean) - (can-focus - :allocation :arg - :accessor widget-can-focus-p - :initarg :can-focus - :type boolean) - (has-focus - :allocation :arg - :accessor widget-has-focus-p - :initarg :has-focus - :type boolean) - (can-default - :allocation :arg - :accessor widget-can-default-p - :initarg :can-default - :type boolean) - (has-default - :allocation :arg - :accessor widget-has-default-p - :initarg :has-default - :type boolean) - (receives-default - :allocation :arg - :accessor widget-receives-default-p - :initarg :receives-default - :type boolean) - (composite-child - :allocation :arg - :accessor widget-composite-child-p - :initarg :composite-child - :type boolean) -; (style -; :allocation :arg -; :accessor widget-style -; :initarg :style -; :type style) - (events - :allocation :arg - :accessor widget-events - :initarg :events - :type gdk:event-mask) - (extension-events - :allocation :arg - :accessor widget-extension-events - :initarg :extpension-events - :type gdk:event-mask) - (state - :allocation :virtual - :location ("gtk_widget_get_state" "gtk_widget_set_state") - :accessor widget-state - :initarg :state - :type state-type) - (window - :allocation :virtual - :location "gtk_widget_get_window" - :reader widget-window - :type gdk:window) - (colormap - :allocation :virtual - :location "gtk_widget_get_colormap" - :reader widget-colormap - :type gdk:colormap) - (visual - :allocation :virtual - :location "gtk_widget_get_visual" - :reader widget-visual - :type gdk:visual)) - (:metaclass object-class) - (:alien-name "GtkWidget"))) - - -(defmethod initialize-instance ((widget widget) &rest initargs &key parent) - (declare (ignore initargs)) +(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))))) + +(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 slot-unbound ((class gobject-class) (object widget) + (slot (eql 'child-properties))) (cond - ((consp parent) - (with-slots ((container parent) child-slots) widget - (setf - container (car parent) - child-slots - (apply - #'make-instance - (slot-value (class-of container) 'child-class) - :parent container :child widget (cdr parent))))) - (parent - (setf (slot-value widget 'parent) parent))) - (call-next-method)) - - -(defmethod slot-unbound ((class object-class) (object widget) slot) - (cond - ((and (eq slot 'child-slots) (slot-value object 'parent)) - (with-slots (parent child-slots) object - (setf - child-slots - (make-instance - (slot-value (class-of parent) 'child-class) + ((slot-boundp object 'parent) + (with-slots (parent child-properties) object + (setf child-properties + (make-instance + (gethash (class-of parent) *container-to-child-class-mappings*) :parent parent :child object)))) - (t (call-next-method)))) + ((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) + #'(lambda (&rest args) + (if (slot-boundp widget 'parent) + (apply function (widget-parent widget) (rest args)) + ;; Delay until parent is set + (signal-connect widget 'parent-set + #'(lambda (old-parent) + (declare (ignore old-parent)) + (let ((*signal-stop-emission* + #'(lambda () + (warn "Ignoring emission stop in delayed signal handler")))) + (apply function (widget-parent widget) (rest args)))) + :remove t) +; (warn "Widget has no parent -- ignoring signal") + )) + (call-next-method))) + +(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)) -(defun child-slot-value (widget slot) - (slot-value (widget-child-slots widget) slot)) +;;; Bindings -(defun (setf child-slot-value) (value widget slot) - (setf (slot-value (widget-child-slots widget) slot) value)) +(defbinding widget-destroy () nil + (widget widget)) -(defmacro with-child-slots (slots widget &body body) - `(with-slots ,slots (widget-child-slots ,widget) - ,@body)) +(defbinding widget-unparent () nil + (widget widget)) -(defmacro widget-destroyed (place) - `(setf ,place nil)) +(defbinding widget-show () nil + (widget widget)) -(define-foreign widget-destroy () nil +(defbinding widget-show-now () nil (widget widget)) -(define-foreign widget-unparent () nil +(defbinding widget-hide () nil (widget widget)) -(define-foreign widget-show () nil +(defbinding widget-show-all () nil (widget widget)) -(define-foreign widget-show-now () nil +(defbinding widget-hide-all () nil (widget widget)) -(define-foreign widget-hide () nil +(defbinding widget-map () nil (widget widget)) -(define-foreign widget-show-all () nil +(defbinding widget-unmap () nil (widget widget)) -(define-foreign widget-hide-all () nil +(defbinding widget-realize () nil (widget widget)) -(define-foreign widget-map () nil +(defbinding widget-unrealize () nil (widget widget)) -(define-foreign widget-unmap () nil +(defbinding widget-queue-draw () nil (widget widget)) -(define-foreign widget-realize () nil +(defbinding widget-queue-resize () nil (widget widget)) -(define-foreign widget-unrealize () nil +(defbinding widget-queue-resize-no-redraw () nil (widget widget)) -(define-foreign widget-add-accelerator +(defbinding widget-size-request + (widget &optional (requisition (make-instance 'requisition))) nil + (widget widget) + (requisition requisition :return)) + +(defbinding widget-get-child-requisition + (widget &optional (requisition (make-instance 'requisition))) nil + (widget widget) + (requisition requisition :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) @@ -225,169 +151,332 @@ (define-foreign widget-add-accelerator (modifiers gdk:modifier-type) (flags accel-flags)) -(define-foreign widget-remove-accelerator +(defbinding widget-remove-accelerator (widget accel-group key modifiers) nil (widget widget) (accel-group accel-group) ((gdk:keyval-from-name key) unsigned-int) (modifiers gdk:modifier-type)) -(define-foreign widget-accelerator-signal - (widget accel-group key modifiers) unsigned-int +(defbinding widget-set-accel-path () nil (widget widget) - (accel-group accel-group) - ((gdk:keyval-from-name key) unsigned-int) - (modifiers gdk:modifier-type)) + (accel-path string) + (accel-group accel-group)) -(define-foreign widget-lock-accelerators () nil +(defbinding widget-list-accel-closures () (glist pointer) (widget widget)) -(define-foreign widget-unlock-accelerators () nil +(defbinding widget-can-activate-accel-p () boolean + (widget widget) + (signal-id unsigned-int)) + +(defbinding widget-event () boolean + (widget widget) + (event gdk:event)) + +(defbinding widget-activate () boolean (widget widget)) -(define-foreign - ("gtk_widget_accelerators_locked" widget-accelerators-locked-p) () boolean +(defbinding widget-reparent () nil + (widget widget) + (new-parent widget)) + +(defbinding %widget-intersect () boolean + (widget widget) + (area gdk:rectangle) + (intersection (or null gdk:rectangle))) + +(defun widget-intersection (widget area) + (let ((intersection (make-instance 'gdk:rectangle))) + (when (%widget-intersect widget area intersection) + intersection))) + +(defun widget-intersect-p (widget area) + (%widget-intersect widget area nil)) + +(defbinding widget-grab-focus () nil (widget widget)) -(define-foreign widget-event () int +(defbinding widget-grab-default () nil + (widget widget)) + +(defbinding widget-add-events () nil (widget widget) - (event gdk:event)) + (events gdk:event-mask)) -(define-foreign widget-activate () boolean +(defbinding widget-get-toplevel () widget (widget widget)) -(define-foreign widget-set-scroll-adjustments () boolean +(defbinding widget-get-ancestor (widget type) widget (widget widget) - (hadjustment adjustment) - (vadjustment adjustment)) + ((find-type-number type) type-number)) -(define-foreign widget-reparent () nil +(defbinding widget-get-pointer () nil (widget widget) - (new-parent widget)) + (x int :out) + (y int :out)) -(define-foreign widget-popup () nil +(defbinding widget-is-ancestor-p () boolean (widget widget) - (x int) - (y int)) + (ancestor widget)) -(define-foreign widget-grab-focus () nil +(defbinding widget-translate-coordinates () boolean + (src-widget widget) + (dest-widget widget) + (src-x int) (src-y int) + (set-x int :out) (dest-y int :out)) + +(defun widget-hide-on-delete (widget) + "Utility function; intended to be connected to the DELETE-EVENT +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 +window. By default, GTK+ destroys windows when DELETE-EVENT is +received." + (widget-hide widget) + t) + +(defbinding widget-ensure-style () nil (widget widget)) -(define-foreign widget-grab-default () nil +(defbinding widget-reset-rc-styles () nil (widget widget)) -;; cl-gtk.c -(define-foreign widget-allocation () nil +(defbinding widget-push-colormap () nil + (colormap gdk:colormap)) + +(defbinding widget-pop-colormap () nil) + +(defbinding %widget-set-default-colormap () nil + (colormap gdk:colormap)) + +(defun (setf widget-default-colormap) (colormap) + (%widget-set-default-colormap colormap) + colormap) + +(defbinding (widget-default-style "gtk_widget_get_default_style") () style) + +(defbinding (widget-default-colromap "gtk_widget_get_default_colormap") + () gdk:colormap) + +(defbinding (widget-default-visual "gtk_widget_get_default_visual") + () gdk:visual) + +(defbinding (widget-default-direction "gtk_widget_get_default_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) - (width int :out) - (height int :out)) + (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)) -(define-foreign widget-set-uposition (widget &key (x t) (y t)) nil +(defbinding widget-class-path () nil (widget widget) - ((case x - ((t) -2) - ((nil) -1) - (otherwise x)) int) - ((case y - ((t) -2) - ((nil) -1) - (otherwise y)) int)) + (path-length int :out) + (path string :out) + (reverse-path string :out)) -(define-foreign widget-add-events () nil +(defbinding widget-modify-style () nil (widget widget) - (events gdk:event-mask)) + (style rc-style)) -(define-foreign ("gtk_widget_get_toplevel" widget-toplevel) () widget +(defbinding widget-get-modifier-style () rc-style (widget widget)) -(define-foreign ("gtk_widget_get_ancestor" - widget-ancestor) (widget type) widget +(defbinding widget-modify-fg () nil (widget widget) - ((find-type-number type) type-number)) + (state state-type) + (color gdk:color)) -; (define-foreign ("gtk_widget_get_colormap" widget-colormap) () gdk:colormap -; (widget widget)) +(defbinding widget-modify-bg () nil + (widget widget) + (state state-type) + (color gdk:color)) -; (define-foreign ("gtk_widget_get_visual" widget-visual) () gdk:visual -; (widget widget)) +(defbinding widget-modify-text () nil + (widget widget) + (state state-type) + (color gdk:color)) -(define-foreign ("gtk_widget_get_pointer" widget-pointer) () nil +(defbinding widget-modify-base () nil (widget widget) - (x int :out) - (y int :out)) + (state state-type) + (color gdk:color)) -(define-foreign ("gtk_widget_is_ancestor" widget-is-ancestor-p) () boolean +(defbinding widget-modify-font () nil (widget widget) - (ancestor widget)) + (state state-type) + (font-desc pango:font-description)) -(define-foreign widget-set-rc-style () nil +(defbinding widget-create-pango-context () pango:context (widget widget)) -(define-foreign widget-ensure-style () nil +(defbinding widget-get-pango-context () pango:context (widget widget)) -(define-foreign widget-restore-default-style () nil +(defbinding widget-create-pango-layout (widget &optional text) pango:layout + (widget widget) + (text (or string null))) + +(defbinding widget-render-icon (widget stock-id &optional size detail) + gdk:pixbuf + (widget widget) + (stock-id string) + ((or size -1) (or icon-size int)) + (detail (or null string))) + +(defbinding widget-push-composite-child () nil) + +(defbinding widget-pop-composite-child () nil) + +(defbinding widget-queue-draw-area () nil + (widget widget) + (x int) (y int) (width int) (height int)) + +(defbinding widget-reset-shapes () nil (widget widget)) -(define-foreign widget-reset-rc-styles () nil +;; (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-scroll-adjustments () boolean + (widget widget) + (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 () 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)) -(defun (setf widget-cursor) (cursor-type widget) - (let ((cursor (gdk:cursor-new cursor-type)) - (window (widget-window widget))) - (gdk:window-set-cursor window cursor) - ;(gdk:cursor-destroy cursor) - )) +(defbinding widget-child-focus () boolean + (widget widget) + (direction direction-type)) -;; Push/pop pairs, to change default values upon a widget's creation. -;; This will override the values that got set by the -;; widget-set-default-* functions. +(defbinding widget-child-notify () nil + (widget widget) + (child-property string)) -(define-foreign widget-push-style () nil - (style style)) +(defbinding widget-freeze-child-notify () nil + (widget widget)) -(define-foreign widget-push-colormap () nil - (colormap gdk:colormap)) +(defbinding widget-get-clipboard () clipboard + (widget widget) + (selection int #|gdk:atom|#)) -; (define-foreign widget-push-visual () nil -; (visual gdk:visual)) +(defbinding widget-get-display () gdk:display + (widget widget)) -(define-foreign widget-push-composite-child () nil) +(defbinding widget-get-root-window () gdk:window + (widget widget)) -(define-foreign widget-pop-style () nil) +(defbinding widget-get-screen () gdk:screen + (widget widget)) -(define-foreign widget-pop-colormap () nil) +(defbinding widget-has-screen-p () boolean + (widget widget)) -;(define-foreign widget-pop-visual () nil) +(defbinding %widget-get-size-request () nil + (widget widget) + (width int :out) + (height int :out)) -(define-foreign widget-pop-composite-child () 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)))) +(defbinding widget-set-size-request (widget width height) nil + (widget widget) + ((or width -1) int) + ((or height -1) int)) -;; Set certain default values to be used at widget creation time. +(defbinding widget-thaw-child-notify () nil + (widget widget)) -(define-foreign widget-set-default-style () nil - (style style)) +(defbinding widget-list-mnemonic-labels () (glist widget) + (widget widget)) -(define-foreign widget-set-default-colormap () nil - (colormap gdk:colormap)) +(defbinding widget-add-mnemonic-label () nil + (widget widget) + (label widget)) -; (define-foreign widget-set-default-visual () nil -; (visual gdk:visual)) +(defbinding widget-remove-mnemonic-label () nil + (widget widget) + (label widget)) -(define-foreign widget-get-default-style () style) -(define-foreign widget-get-default-colormap () gdk:colormap) +;;; Additional bindings and functions -(define-foreign widget-get-default-visual () gdk:visual) +(defbinding (widget-mapped-p "gtk_widget_mapped_p") () boolean + (widget widget)) -(define-foreign widget-shape-combine-mask () nil +(defbinding widget-get-size-allocation () nil (widget widget) - (shape-mask gdk:bitmap) - (x-offset int) - (y-offset int)) + (width int :out) + (height int :out)) + +(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))) -;; cl-gtk.c -(define-foreign widget-mapped-p () boolean +(defbinding %widget-get-parent-window () gdk:window (widget widget)) +(defun %widget-parent-window (widget) + (when (slot-boundp widget 'parent) + (%widget-get-parent-window widget)))