From 18681848c901d1e0eb876c8b8c1b7d4106270326 Mon Sep 17 00:00:00 2001 From: patthoyts Date: Tue, 19 Jan 2010 01:27:40 +0000 Subject: TIP #359: Extended window manager hints support for X11. Modern unix window managers use a set of window properties to give hints as to the purpose of a toplevel window. They then use these hints to apply various animation and decoration options based on the type (dialog, menu, tooltip and more). This patch adds a [wm attributes $w -type] option to control and read the type hint and makes use of this for the ttk::combobox and the dialogs raised from the Tk library scripts. Signed-off-by: Pat Thoyts --- ChangeLog | 13 ++++ library/bgerror.tcl | 4 +- library/clrpick.tcl | 3 +- library/demos/widget | 4 +- library/dialog.tcl | 4 +- library/msgbox.tcl | 4 +- library/tkfbox.tcl | 3 +- library/ttk/combobox.tcl | 6 +- tests/unixWm.test | 51 +++++++++++++++- tests/wm.test | 4 +- unix/tkUnixWm.c | 152 +++++++++++++++++++++++++++++++++++++++++++---- 11 files changed, 223 insertions(+), 25 deletions(-) diff --git a/ChangeLog b/ChangeLog index dd06354..c075fcb 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,16 @@ +2010-01-19 Pat Thoyts + + * library/bgerror.tcl: [TIP 359]: Extended Window Manager Hints + * library/clrpick.tcl: following the freedesktop.org specification + * library/demos/widget: are now supported on X11 using a new + * library/dialog.tcl: wm attribute called '-type' + * library/msgbox.tcl: This feature is now used in the Tk library + * library/tkfbox.tcl: functions where appropriate. + * library/ttk/combobox.tcl: + * tests/unixWm.test: + * tests/wm.test: + * unix/tkUnixWm.c: + 2010-01-18 Jan Nijtmans * generic/tkCanvArc.c fix more gcc warnings: missing initializer diff --git a/library/bgerror.tcl b/library/bgerror.tcl index 54e764e..8a0dd0b 100644 --- a/library/bgerror.tcl +++ b/library/bgerror.tcl @@ -11,7 +11,7 @@ # Copyright (c) 2007 Daniel A. Steffen # Copyright (c) 2009 Pat Thoyts # -# RCS: @(#) $Id: bgerror.tcl,v 1.40 2009/01/11 11:51:39 patthoyts Exp $ +# RCS: @(#) $Id: bgerror.tcl,v 1.41 2010/01/19 01:27:41 patthoyts Exp $ # namespace eval ::tk::dialog::error { @@ -146,6 +146,8 @@ proc ::tk::dialog::error::bgerror err { if {$windowingsystem eq "aqua"} { ::tk::unsupported::MacWindowStyle style $dlg moveableAlert {} + } elseif {$windowingsystem eq "x11"} { + wm attributes $dlg -type dialog } ttk::frame $dlg.bot diff --git a/library/clrpick.tcl b/library/clrpick.tcl index 216cdb8..083de84 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.22 2006/03/17 11:13:15 patthoyts Exp $ +# RCS: @(#) $Id: clrpick.tcl,v 1.23 2010/01/19 01:27:41 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/demos/widget b/library/demos/widget index e2c47ce..21bde4f 100644 --- a/library/demos/widget +++ b/library/demos/widget @@ -10,7 +10,7 @@ exec wish "$0" ${1+"$@"} # separate ".tcl" files is this directory, which are sourced by this script as # needed. # -# RCS: @(#) $Id: widget,v 1.58 2009/12/10 11:48:38 dkf Exp $ +# RCS: @(#) $Id: widget,v 1.59 2010/01/19 01:27:41 patthoyts Exp $ package require Tcl 8.5 package require Tk 8.5 @@ -458,6 +458,7 @@ proc positionWindow w { proc showVars {w args} { catch {destroy $w} toplevel $w + if {[tk windowingsystem] eq "x11"} {wm attributes $w -type dialog} wm title $w [mc "Variable values"] set b [ttk::frame $w.frame] @@ -559,6 +560,7 @@ proc showCode w { set top .code if {![winfo exists $top]} { toplevel $top + if {[tk windowingsystem] eq "x11"} {wm attributes $top -type dialog} set t [frame $top.f] set text [text $t.text -font fixedFont -height 24 -wrap word \ diff --git a/library/dialog.tcl b/library/dialog.tcl index 5012823..162ecbe 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.25 2010/01/04 21:22:08 patthoyts Exp $ +# RCS: @(#) $Id: dialog.tcl,v 1.26 2010/01/19 01:27:41 patthoyts Exp $ # # Copyright (c) 1992-1993 The Regents of the University of California. # Copyright (c) 1994-1997 Sun Microsystems, Inc. @@ -74,6 +74,8 @@ proc ::tk_dialog {w title text bitmap default args} { if {$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 41e3960..0f77f7a 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.39 2009/08/24 21:22:46 dkf Exp $ +# RCS: @(#) $Id: msgbox.tcl,v 1.40 2010/01/19 01:27:41 patthoyts Exp $ # # Copyright (c) 1994-1997 Sun Microsystems, Inc. # @@ -269,6 +269,8 @@ proc ::tk::MessageBox {args} { if {$windowingsystem eq "aqua"} { ::tk::unsupported::MacWindowStyle style $w moveableModal {} + } elseif {$windowingsystem eq "x11"} { + wm attributes $w -type dialog } ttk::frame $w.bot diff --git a/library/tkfbox.tcl b/library/tkfbox.tcl index b3c7156..0e091ab 100644 --- a/library/tkfbox.tcl +++ b/library/tkfbox.tcl @@ -10,7 +10,7 @@ # "Directory" option menu. The user can select files by clicking on the # file icons or by entering a filename in the "Filename:" entry. # -# RCS: @(#) $Id: tkfbox.tcl,v 1.75 2009/10/22 10:12:57 dkf Exp $ +# RCS: @(#) $Id: tkfbox.tcl,v 1.76 2010/01/19 01:27:41 patthoyts Exp $ # # Copyright (c) 1994-1998 Sun Microsystems, Inc. # @@ -330,6 +330,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} pack [ttk::frame $w.contents] -expand 1 -fill both #set w $w.contents diff --git a/library/ttk/combobox.tcl b/library/ttk/combobox.tcl index ff41366..20bfc07 100644 --- a/library/ttk/combobox.tcl +++ b/library/ttk/combobox.tcl @@ -1,5 +1,5 @@ # -# $Id: combobox.tcl,v 1.19 2009/11/12 18:17:14 jenglish Exp $ +# $Id: combobox.tcl,v 1.20 2010/01/19 01:27:41 patthoyts Exp $ # # Combobox bindings. # @@ -271,8 +271,7 @@ proc ttk::combobox::PopdownWindow {cb} { if {![winfo exists $cb.popdown]} { set poplevel [PopdownToplevel $cb.popdown] - - set popdown [ttk::frame $poplevel.f -style ComboboxPopdownFrame] + set popdown [ttk::frame $poplevel.f -style ComboboxPopdownFrame] $scrollbar $popdown.sb \ -orient vertical -command [list $popdown.l yview] @@ -310,6 +309,7 @@ proc ttk::combobox::PopdownToplevel {w} { default - x11 { $w configure -relief flat -borderwidth 0 + wm attributes $w -type combo wm overrideredirect $w true } win32 { diff --git a/tests/unixWm.test b/tests/unixWm.test index c55578b..6f580d8 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.46 2008/10/08 18:57:47 dgp Exp $ +# RCS: @(#) $Id: unixWm.test,v 1.47 2010/01/19 01:27:41 patthoyts Exp $ package require tcltest 2.2 eval tcltest::configure $argv @@ -2446,7 +2446,7 @@ test unixWm-60.1 {wm attributes - test} -constraints unix -body { destroy .t toplevel .t wm attributes .t -} -result [list -alpha 1.0 -topmost 0 -zoomed 0 -fullscreen 0] +} -result [list -alpha 1.0 -topmost 0 -zoomed 0 -fullscreen 0 -type {}] test unixWm-60.2 {wm attributes - test} -constraints unix -body { destroy .t @@ -2486,6 +2486,53 @@ test unixWm-61.2 {Tk_WmCmd procedure, "iconphoto" option} unix { image delete blank16 blank32 } {} +test unixWm-62.0 {wm attributes -type void} -constraints unix -setup { + destroy .t + toplevel .t +} -body { + wm attributes .t -type {} +} -cleanup { + destroy .t +} -result {} + +test unixWm-62.1 {wm attributes -type name} -constraints unix -setup { + destroy .t + toplevel .t +} -body { + wm attributes .t -type dialog +} -cleanup { + destroy .t +} -result {} + +test unixWm-62.1 {wm attributes -type name} -constraints unix -setup { + destroy .t + toplevel .t +} -body { + tkwait visibility .t + wm attributes .t -type dialog +} -cleanup { + destroy .t +} -result {} + +test unixWm-62.2 {wm attributes -type list} -constraints unix -setup { + destroy .t + toplevel .t +} -body { + wm attributes .t -type {xyzzy dialog} +} -cleanup { + destroy .t +} -result {} + +test unixWm-62.2 {wm attributes -type list} -constraints unix -setup { + destroy .t + toplevel .t +} -body { + tkwait visibility .t + wm attributes .t -type {xyzzy dialog} +} -cleanup { + destroy .t +} -result {} + # cleanup destroy .t cleanupTests diff --git a/tests/wm.test b/tests/wm.test index 1fd024f..0aa229a 100644 --- a/tests/wm.test +++ b/tests/wm.test @@ -7,7 +7,7 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: wm.test,v 1.47 2010/01/06 09:25:15 dkf Exp $ +# RCS: @(#) $Id: wm.test,v 1.48 2010/01/19 01:27:41 patthoyts Exp $ # This file tests window manager interactions that work across platforms. # Window manager tests that only work on a specific platform should be placed @@ -139,7 +139,7 @@ test wm-attributes-1.2.3 {usage} -constraints win -returnCodes error -body { } -result {wrong # args: should be "wm attributes window ?-alpha ?double?? ?-transparentcolor ?color?? ?-disabled ?bool?? ?-fullscreen ?bool?? ?-toolwindow ?bool?? ?-topmost ?bool??"} test wm-attributes-1.2.4 {usage} -constraints {unix notAqua} -returnCodes error -body { wm attributes . _ -} -result {bad attribute "_": must be -alpha, -topmost, -zoomed, or -fullscreen} +} -result {bad attribute "_": must be -alpha, -topmost, -zoomed, -fullscreen, or -type} test wm-attributes-1.2.5 {usage} -constraints aqua -returnCodes error -body { wm attributes . _ } -result {bad attribute "_": must be -alpha, -modified, -notify, or -titlepath} diff --git a/unix/tkUnixWm.c b/unix/tkUnixWm.c index adfb31d..e09f66d 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.78 2010/01/06 09:25:15 dkf Exp $ + * RCS: @(#) $Id: tkUnixWm.c,v 1.79 2010/01/19 01:27:41 patthoyts Exp $ */ #include "tkUnixInt.h" @@ -52,12 +52,12 @@ typedef struct { typedef enum { WMATT_ALPHA, WMATT_TOPMOST, WMATT_ZOOMED, WMATT_FULLSCREEN, - _WMATT_LAST_ATTRIBUTE + WMATT_TYPE, _WMATT_LAST_ATTRIBUTE } WmAttribute; static const char *const WmAttributeNames[] = { "-alpha", "-topmost", "-zoomed", "-fullscreen", - NULL + "-type", NULL }; /* @@ -348,6 +348,8 @@ static void UpdateTitle(TkWindow *winPtr); static void UpdatePhotoIcon(TkWindow *winPtr); static void UpdateVRootGeometry(WmInfo *wmPtr); static void UpdateWmProtocols(WmInfo *wmPtr); +static int SetNetWmType(TkWindow *winPtr, Tcl_Obj *typePtr); +static Tcl_Obj * GetNetWmType(TkWindow *winPtr); static void SetNetWmState(TkWindow*, const char *atomName, int on); static void CheckNetWmState(WmInfo *, Atom *atoms, int numAtoms); static void UpdateNetWmState(WmInfo *); @@ -1279,6 +1281,10 @@ WmSetAttribute( } SetNetWmState(winPtr, "_NET_WM_STATE_ABOVE", wmPtr->reqState.topmost); break; + case WMATT_TYPE: + if (TCL_OK != SetNetWmType(winPtr, value)) + return TCL_ERROR; + break; case WMATT_ZOOMED: if (Tcl_GetBooleanFromObj(interp, value, &wmPtr->reqState.zoomed) != TCL_OK) { @@ -1332,6 +1338,8 @@ WmGetAttribute( return Tcl_NewBooleanObj(wmPtr->attributes.zoomed); case WMATT_FULLSCREEN: return Tcl_NewBooleanObj(wmPtr->attributes.fullscreen); + case WMATT_TYPE: + return GetNetWmType(winPtr); case _WMATT_LAST_ATTRIBUTE: /*NOTREACHED*/ break; } @@ -5342,6 +5350,130 @@ UpdateHints( } /* + *---------------------------------------------------------------------- + * + * 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(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 = Tk_Interp(tkwin); + + 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(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 = Tk_Interp(tkwin); + 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 -- @@ -6670,7 +6802,7 @@ TkpMakeMenuWindow( WmInfo *wmPtr; XSetWindowAttributes atts; TkWindow *wrapperPtr; - Atom atom; + Tcl_Obj *typeObj; if (!Tk_HasWrapper(tkwin)) { return; @@ -6683,22 +6815,18 @@ TkpMakeMenuWindow( if (typeFlag == TK_MAKE_MENU_TEAROFF) { atts.override_redirect = False; atts.save_under = False; - atom = Tk_InternAtom((Tk_Window) tkwin, "_NET_WM_WINDOW_TYPE_MENU"); + typeObj = Tcl_NewStringObj("menu", -1); TkSetTransientFor(tkwin, NULL); } else { atts.override_redirect = True; atts.save_under = True; if (typeFlag == TK_MAKE_MENU_DROPDOWN) { - atom = Tk_InternAtom((Tk_Window) tkwin, - "_NET_WM_WINDOW_TYPE_DROPDOWN_MENU"); + typeObj = Tcl_NewStringObj("dropdown_menu", -1); } else { - atom = Tk_InternAtom((Tk_Window) tkwin, - "_NET_WM_WINDOW_TYPE_POPUP_MENU"); + typeObj = Tcl_NewStringObj("popup_menu", -1); } } - XChangeProperty(Tk_Display(tkwin), wrapperPtr->window, - Tk_InternAtom((Tk_Window) tkwin, "_NET_WM_WINDOW_TYPE"), - XA_ATOM, 32, PropModeReplace, (unsigned char *) &atom, 1); + SetNetWmType((TkWindow *)tkwin, typeObj); /* * The override-redirect and save-under bits must be set on the wrapper -- cgit v0.12