From 733aa079ae7a00cc9a223dbe7c241d80b375021e Mon Sep 17 00:00:00 2001 From: patthoyts Date: Sat, 23 Jan 2010 01:36:03 +0000 Subject: TIP #359: Extended Window Manager Hints support for 8.4 --- ChangeLog | 10 +++ library/bgerror.tcl | 6 +- library/clrpick.tcl | 3 +- library/dialog.tcl | 4 +- library/msgbox.tcl | 4 +- library/tkfbox.tcl | 3 +- tests/unixWm.test | 44 ++++++++++++- unix/tkUnixWm.c | 183 ++++++++++++++++++++++++++++++++++++++++++++++++++-- 8 files changed, 244 insertions(+), 13 deletions(-) diff --git a/ChangeLog b/ChangeLog index b07c1c6..37542f2 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,13 @@ +2010-01-23 Pat Thoyts + + * library/bgerror.tcl: [TIP #359]: Extended Window Manager Hints + * library/clrpick.tcl: backported from 8.5 for use on X11. + * library/dialog.tcl: + * library/msgbox.tcl: + * library/tkfbox.tcl: + * tests/unixWm.test: + * unix/tkUnixWm.c: + 2009-12-11 Donal K. Fellows * library/tk.tcl (::tk::ScreenChanged): [Bug 2912473]: Stop problems diff --git a/library/bgerror.tcl b/library/bgerror.tcl index 2e6229b..b0b3d9d 100644 --- a/library/bgerror.tcl +++ b/library/bgerror.tcl @@ -9,8 +9,8 @@ # Copyright (c) 1998-2000 by Ajuba Solutions. # Copyright (c) 2007 Daniel A. Steffen # -# RCS: @(#) $Id: bgerror.tcl,v 1.23.2.9 2007/11/09 06:26:54 das Exp $ -# $Id: bgerror.tcl,v 1.23.2.9 2007/11/09 06:26:54 das Exp $ +# RCS: @(#) $Id: bgerror.tcl,v 1.23.2.10 2010/01/23 01:36:03 patthoyts Exp $ +# $Id: bgerror.tcl,v 1.23.2.10 2010/01/23 01:36:03 patthoyts Exp $ namespace eval ::tk::dialog::error { namespace import -force ::tk::msgcat::* @@ -149,6 +149,8 @@ proc ::tk::dialog::error::bgerror err { if {($tcl_platform(platform) eq "macintosh") || ($windowingsystem eq "aqua")} { ::tk::unsupported::MacWindowStyle style .bgerrorDialog moveableAlert {} + } elseif {$windowingsystem eq "x11"} { + wm attributes .bgerrorDialog -type dialog } frame .bgerrorDialog.bot diff --git a/library/clrpick.tcl b/library/clrpick.tcl index ac47150..cb4b6d4 100644 --- a/library/clrpick.tcl +++ b/library/clrpick.tcl @@ -3,7 +3,7 @@ # Color selection dialog for platforms that do not support a # standard color selection dialog. # -# RCS: @(#) $Id: clrpick.tcl,v 1.20.2.2 2006/03/17 10:50:11 patthoyts Exp $ +# RCS: @(#) $Id: clrpick.tcl,v 1.20.2.3 2010/01/23 01:36:03 patthoyts Exp $ # # Copyright (c) 1996 Sun Microsystems, Inc. # @@ -74,6 +74,7 @@ proc ::tk::dialog::color:: {args} { destroy $w } toplevel $w -class TkColorDialog -screen $sc + if {[tk windowingsystem] eq "x11"} {wm attributes $w -type dialog} BuildDialog $w } diff --git a/library/dialog.tcl b/library/dialog.tcl index e083cf1..d94a0b2 100644 --- a/library/dialog.tcl +++ b/library/dialog.tcl @@ -3,7 +3,7 @@ # This file defines the procedure tk_dialog, which creates a dialog # box containing a bitmap, a message, and one or more buttons. # -# RCS: @(#) $Id: dialog.tcl,v 1.14.2.5 2007/05/30 06:37:03 das Exp $ +# RCS: @(#) $Id: dialog.tcl,v 1.14.2.6 2010/01/23 01:36:03 patthoyts Exp $ # # Copyright (c) 1992-1993 The Regents of the University of California. # Copyright (c) 1994-1997 Sun Microsystems, Inc. @@ -75,6 +75,8 @@ proc ::tk_dialog {w title text bitmap default args} { if {$tcl_platform(platform) eq "macintosh" || $windowingsystem eq "aqua"} { ::tk::unsupported::MacWindowStyle style $w moveableModal {} + } elseif {$windowingsystem eq "x11"} { + wm attributes $w -type dialog } frame $w.bot diff --git a/library/msgbox.tcl b/library/msgbox.tcl index 2f8419b..045a433 100644 --- a/library/msgbox.tcl +++ b/library/msgbox.tcl @@ -3,7 +3,7 @@ # Implements messageboxes for platforms that do not have native # messagebox support. # -# RCS: @(#) $Id: msgbox.tcl,v 1.24.2.4 2007/05/30 06:37:03 das Exp $ +# RCS: @(#) $Id: msgbox.tcl,v 1.24.2.5 2010/01/23 01:36:03 patthoyts Exp $ # # Copyright (c) 1994-1997 Sun Microsystems, Inc. # @@ -263,6 +263,8 @@ proc ::tk::MessageBox {args} { if {$windowingsystem eq "classic" || $windowingsystem eq "aqua"} { ::tk::unsupported::MacWindowStyle style $w moveableModal {} + } elseif {$windowingsystem eq "x11"} { + wm attributes $w -type dialog } frame $w.bot -background $bg diff --git a/library/tkfbox.tcl b/library/tkfbox.tcl index e32dbe7..c55c8e8 100644 --- a/library/tkfbox.tcl +++ b/library/tkfbox.tcl @@ -11,7 +11,7 @@ # files by clicking on the file icons or by entering a filename # in the "Filename:" entry. # -# RCS: @(#) $Id: tkfbox.tcl,v 1.38.2.13 2007/02/19 23:53:36 hobbs Exp $ +# RCS: @(#) $Id: tkfbox.tcl,v 1.38.2.14 2010/01/23 01:36:03 patthoyts Exp $ # # Copyright (c) 1994-1998 Sun Microsystems, Inc. # @@ -1001,6 +1001,7 @@ proc ::tk::dialog::file::Create {w class} { global tk_library toplevel $w -class $class + if {[tk windowingsystem] eq "x11"} {wm attributes $w -type dialog} # f1: the frame with the directory option menu # diff --git a/tests/unixWm.test b/tests/unixWm.test index bca1f5e..1c3f352 100644 --- a/tests/unixWm.test +++ b/tests/unixWm.test @@ -7,7 +7,7 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: unixWm.test,v 1.29.2.4 2005/01/14 21:09:47 jenglish Exp $ +# RCS: @(#) $Id: unixWm.test,v 1.29.2.5 2010/01/23 01:36:03 patthoyts Exp $ package require tcltest 2.2 namespace import -force tcltest::configure @@ -2397,12 +2397,12 @@ test unixWm-60.1 {wm attributes} unix { destroy .t toplevel .t wm attributes .t -} {} +} {-type {}} test unixWm-60.2 {wm attributes} unix { destroy .t toplevel .t list [catch {wm attributes .t -foo} msg] $msg -} {1 {wrong # args: should be "wm attributes window"}} +} {1 {wrong # args: should be "wm attributes window ?-type list?"}} test unixWm-61.1 {Tk_WmCmd procedure, "iconphoto" option} unix { list [catch {wm iconph .} msg] $msg @@ -2417,6 +2417,44 @@ test unixWm-61.2 {Tk_WmCmd procedure, "iconphoto" option} unix { image delete blank16 blank32 } {} +test unixWm-62.0 {wm attributes -type void} unix { + destroy .t + toplevel .t + set r [list [catch {wm attributes .t -type {}} err] $err] + destroy .t + set r +} {0 {}} +test unixWm-62.1 {wm attributes -type name} unix { + destroy .t + toplevel .t + set r [list [catch {wm attributes .t -type dialog} err] $err] + destroy .t + set r +} {0 {}} +test unixWm-62.1 {wm attributes -type name} unix { + destroy .t + toplevel .t + tkwait visibility .t + set r [list [catch {wm attributes .t -type dialog} err] $err] + destroy .t + set r +} {0 {}} +test unixWm-62.2 {wm attributes -type list} unix { + destroy .t + toplevel .t + set r [list [catch {wm attributes .t -type {xyzzy dialog}} err] $err] + destroy .t + set r +} {0 {}} +test unixWm-62.2 {wm attributes -type list} unix { + destroy .t + toplevel .t + tkwait visibility .t + set r [list [catch {wm attributes .t -type {xyzzy dialog}} err] $err] + destroy .t + set r +} {0 {}} + # cleanup catch {destroy .t} ::tcltest::cleanupTests diff --git a/unix/tkUnixWm.c b/unix/tkUnixWm.c index 3c92139..234b23f 100644 --- a/unix/tkUnixWm.c +++ b/unix/tkUnixWm.c @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tkUnixWm.c,v 1.36.2.7 2006/04/11 20:23:45 hobbs Exp $ + * RCS: @(#) $Id: tkUnixWm.c,v 1.36.2.8 2010/01/23 01:36:03 patthoyts Exp $ */ #include "tkPort.h" @@ -324,6 +324,11 @@ static int ParseGeometry _ANSI_ARGS_((Tcl_Interp *interp, char *string, TkWindow *winPtr)); static void ReparentEvent _ANSI_ARGS_((WmInfo *wmPtr, XReparentEvent *eventPtr)); +static int SetNetWmType _ANSI_ARGS_((TkWindow *winPtr, + Tcl_Obj *typePtr)); +static Tcl_Obj * GetNetWmType _ANSI_ARGS_((TkWindow *winPtr)); +static void TkSetTransientFor _ANSI_ARGS_((Tk_Window tkwin, + Tk_Window parent)); static void TkWmStackorderToplevelWrapperMap _ANSI_ARGS_(( TkWindow *winPtr, Display *display, @@ -1206,11 +1211,23 @@ WmAttributesCmd(tkwin, winPtr, interp, objc, objv) int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "window"); + if (objc < 4) { + Tcl_Obj *listObj = Tcl_NewListObj(0, NULL); + Tcl_ListObjAppendElement(interp, listObj, + Tcl_NewStringObj("-type", -1)); + Tcl_ListObjAppendElement(interp, listObj, GetNetWmType(winPtr)); + Tcl_SetObjResult(interp, listObj); + return TCL_OK; + } + if (objc > 5 || strcmp("-type", Tcl_GetString(objv[3]))) { + Tcl_WrongNumArgs(interp, 2, objv, "window ?-type list?"); return TCL_ERROR; } - return TCL_OK; + if (objc == 4) { + Tcl_SetObjResult(interp, GetNetWmType(winPtr)); + return TCL_OK; + } + return SetNetWmType(winPtr, objv[4]); } /* @@ -4844,6 +4861,133 @@ UpdateHints(winPtr) } /* + *---------------------------------------------------------------------- + * + * SetNetWmType -- + * + * Set the extended window manager hints for a toplevel window + * to the types provided. The specification states that this + * may be a list of window types in preferred order. To permit + * for future type definitions, the set of names is unconstrained + * and names are converted to upper-case and appended to + * "_NET_WM_WINDOW_TYPE_" before being converted to an Atom. + * + *---------------------------------------------------------------------- + */ + +static int +SetNetWmType(winPtr, typePtr) + TkWindow *winPtr; + Tcl_Obj *typePtr; +{ + Atom typeAtom, *atoms = NULL; + WmInfo *wmPtr; + TkWindow *wrapperPtr; + Tcl_Obj **objv; + int objc, n; + Tk_Window tkwin = (Tk_Window)winPtr; + Tcl_Interp *interp = winPtr->mainPtr->interp; + + if (TCL_OK != Tcl_ListObjGetElements(interp, typePtr, &objc, &objv)) { + return TCL_ERROR; + } + + if (!Tk_HasWrapper(tkwin)) { + return TCL_OK; /* error?? */ + } + + if (objc > 0) { + atoms = (Atom *)ckalloc(sizeof(Atom) * objc); + } + + for (n = 0; n < objc; ++n) { + Tcl_DString ds, dsName; + int len; + char *name = Tcl_GetStringFromObj(objv[n], &len); + Tcl_UtfToUpper(name); + Tcl_UtfToExternalDString(NULL, name, len, &dsName); + Tcl_DStringInit(&ds); + Tcl_DStringAppend(&ds, "_NET_WM_WINDOW_TYPE_", 20); + Tcl_DStringAppend(&ds, Tcl_DStringValue(&dsName), + Tcl_DStringLength(&dsName)); + Tcl_DStringFree(&dsName); + atoms[n] = Tk_InternAtom(tkwin, Tcl_DStringValue(&ds)); + Tcl_DStringFree(&ds); + } + + wmPtr = winPtr->wmInfoPtr; + if (wmPtr->wrapperPtr == NULL) { + CreateWrapper(wmPtr); + } + wrapperPtr = wmPtr->wrapperPtr; + + typeAtom = Tk_InternAtom(tkwin, "_NET_WM_WINDOW_TYPE"); + XChangeProperty(Tk_Display(tkwin), wrapperPtr->window, typeAtom, + XA_ATOM, 32, PropModeReplace, (unsigned char *) atoms, objc); + + ckfree((char *)atoms); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * GetNetWmType -- + * + * Read the extended window manager type hint from a window + * and return as a list of names suitable for use with + * SetNetWmType. + * + *---------------------------------------------------------------------- + */ + +static Tcl_Obj * +GetNetWmType(winPtr) + TkWindow *winPtr; +{ + Atom typeAtom, actualType, *atoms; + int actualFormat; + unsigned long n, count, bytesAfter; + unsigned char *propertyValue = NULL; + long maxLength = 1024; + Tk_Window tkwin = (Tk_Window)winPtr; + TkWindow *wrapperPtr; + Tcl_Obj *typePtr; + Tcl_Interp *interp; + Tcl_DString ds; + + interp = winPtr->mainPtr->interp; + typePtr = Tcl_NewListObj(0, NULL); + + if (winPtr->wmInfoPtr->wrapperPtr == NULL) { + CreateWrapper(winPtr->wmInfoPtr); + } + wrapperPtr = winPtr->wmInfoPtr->wrapperPtr; + + typeAtom = Tk_InternAtom(tkwin, "_NET_WM_WINDOW_TYPE"); + if (Success == XGetWindowProperty(wrapperPtr->display, + wrapperPtr->window, typeAtom, 0L, maxLength, False, + XA_ATOM, &actualType, &actualFormat, &count, + &bytesAfter, &propertyValue)) { + atoms = (Atom *)propertyValue; + for (n = 0; n < count; ++n) { + const char *name = Tk_GetAtomName(tkwin, atoms[n]); + if (strncmp("_NET_WM_WINDOW_TYPE_", name, 20) == 0) { + Tcl_ExternalToUtfDString(NULL, name+20, -1, &ds); + Tcl_UtfToLower(Tcl_DStringValue(&ds)); + Tcl_ListObjAppendElement(interp, typePtr, + Tcl_NewStringObj(Tcl_DStringValue(&ds), + Tcl_DStringLength(&ds))); + Tcl_DStringFree(&ds); + } + } + XFree(propertyValue); + } + + return typePtr; +} + +/* *-------------------------------------------------------------- * * ParseGeometry -- @@ -6116,6 +6260,32 @@ GetMaxSize(wmPtr, maxWidthPtr, maxHeightPtr) /* *---------------------------------------------------------------------- * + * TkSetTransientFor -- + * + * Set a Tk window to be transient with reference to a specified + * parent or the toplevel ancestor if None is passed as parent. + * + *---------------------------------------------------------------------- + */ + +static void +TkSetTransientFor(tkwin, parent) + Tk_Window tkwin; + Tk_Window parent; +{ + if (parent == None) { + parent = Tk_Parent(tkwin); + while (!Tk_IsTopLevel(parent)) + parent = Tk_Parent(tkwin); + } + XSetTransientForHint(Tk_Display(tkwin), + ((TkWindow *)tkwin)->wmInfoPtr->wrapperPtr->window, + ((TkWindow *)parent)->wmInfoPtr->wrapperPtr->window); +} + +/* + *---------------------------------------------------------------------- + * * TkpMakeMenuWindow -- * * Configure the window to be either a pull-down (or pop-up) @@ -6142,6 +6312,7 @@ TkpMakeMenuWindow(tkwin, transient) WmInfo *wmPtr; XSetWindowAttributes atts; TkWindow *wrapperPtr; + Tcl_Obj *typeObj; if (!Tk_HasWrapper(tkwin)) { return; @@ -6154,10 +6325,14 @@ TkpMakeMenuWindow(tkwin, transient) if (transient) { atts.override_redirect = True; atts.save_under = True; + typeObj = Tcl_NewStringObj("dropdown_menu", -1); } else { atts.override_redirect = False; atts.save_under = False; + typeObj = Tcl_NewStringObj("menu", -1); + TkSetTransientFor(tkwin, None); } + SetNetWmType((TkWindow *)tkwin, typeObj); /* * The override-redirect and save-under bits must be set on the -- cgit v0.12