From 8653f8ec25290721bc6fac2a9c68bbff0a4c4eb3 Mon Sep 17 00:00:00 2001 From: patthoyts Date: Wed, 20 Jan 2010 23:43:50 +0000 Subject: TIP #359: Extended window manager hints support for X11. --- ChangeLog | 13 ++++ library/bgerror.tcl | 6 +- library/clrpick.tcl | 3 +- library/demos/widget | 4 +- library/dialog.tcl | 4 +- library/msgbox.tcl | 4 +- library/tkfbox.tcl | 3 +- library/ttk/combobox.tcl | 3 +- tests/unixWm.test | 51 +++++++++++++++- tests/wm.test | 4 +- unix/tkUnixWm.c | 151 +++++++++++++++++++++++++++++++++++++++++++---- 11 files changed, 223 insertions(+), 23 deletions(-) diff --git a/ChangeLog b/ChangeLog index bd09fbe..bd14d52 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,16 @@ +2010-01-20 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-19 Donal K. Fellows * generic/tkCanvas.c (TagSearchScanExpr): [Bug 2931374]: Stop overflow diff --git a/library/bgerror.tcl b/library/bgerror.tcl index a169e8c..af4f7c0 100644 --- a/library/bgerror.tcl +++ b/library/bgerror.tcl @@ -10,8 +10,8 @@ # Copyright (c) 2007 by ActiveState Software Inc. # Copyright (c) 2007 Daniel A. Steffen # -# RCS: @(#) $Id: bgerror.tcl,v 1.38 2007/12/13 15:26:26 dgp Exp $ -# $Id: bgerror.tcl,v 1.38 2007/12/13 15:26:26 dgp Exp $ +# RCS: @(#) $Id: bgerror.tcl,v 1.38.2.1 2010/01/20 23:43:50 patthoyts Exp $ +# $Id: bgerror.tcl,v 1.38.2.1 2010/01/20 23:43:50 patthoyts Exp $ namespace eval ::tk::dialog::error { namespace import -force ::tk::msgcat::* @@ -142,6 +142,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 } frame $dlg.bot diff --git a/library/clrpick.tcl b/library/clrpick.tcl index 216cdb8..b249e31 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.22.4.1 2010/01/20 23:43:51 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 8fefbbd..5acba79 100644 --- a/library/demos/widget +++ b/library/demos/widget @@ -10,7 +10,7 @@ exec wish "$0" "$@" # separate ".tcl" files is this directory, which are sourced by this script as # needed. # -# RCS: @(#) $Id: widget,v 1.51.2.2 2009/12/10 11:44:07 dkf Exp $ +# RCS: @(#) $Id: widget,v 1.51.2.3 2010/01/20 23:43:51 patthoyts Exp $ package require Tcl 8.5 package require Tk 8.5 @@ -473,6 +473,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] @@ -574,6 +575,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 f2e0eb0..6add77d 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.24.2.1 2010/01/04 21:47:24 patthoyts Exp $ +# RCS: @(#) $Id: dialog.tcl,v 1.24.2.2 2010/01/20 23:43:51 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 1da4607..60b733f 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.36.2.2 2009/08/24 21:19:35 dkf Exp $ +# RCS: @(#) $Id: msgbox.tcl,v 1.36.2.3 2010/01/20 23:43:51 patthoyts Exp $ # # Copyright (c) 1994-1997 Sun Microsystems, Inc. # @@ -271,6 +271,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;# -background $bg diff --git a/library/tkfbox.tcl b/library/tkfbox.tcl index ccf984c..efde934 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.68.2.4 2009/12/22 18:16:05 dkf Exp $ +# RCS: @(#) $Id: tkfbox.tcl,v 1.68.2.5 2010/01/20 23:43:51 patthoyts Exp $ # # Copyright (c) 1994-1998 Sun Microsystems, Inc. # @@ -1047,6 +1047,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 c52f70c..6f34f69 100644 --- a/library/ttk/combobox.tcl +++ b/library/ttk/combobox.tcl @@ -1,5 +1,5 @@ # -# $Id: combobox.tcl,v 1.12.2.2 2008/11/22 22:14:50 patthoyts Exp $ +# $Id: combobox.tcl,v 1.12.2.3 2010/01/20 23:43:51 patthoyts Exp $ # # Combobox bindings. # @@ -298,6 +298,7 @@ proc ttk::combobox::PopdownToplevel {w} { default - x11 { $w configure -relief solid -borderwidth 1 + wm attributes $w -type combo wm overrideredirect $w true } win32 { diff --git a/tests/unixWm.test b/tests/unixWm.test index b7e78dc..2a299f1 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.44 2007/12/13 15:27:55 dgp Exp $ +# RCS: @(#) $Id: unixWm.test,v 1.44.2.1 2010/01/20 23:43:52 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 05e0f65..e58a4a1 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.39.2.3 2010/01/06 09:30:21 dkf Exp $ +# RCS: @(#) $Id: wm.test,v 1.39.2.4 2010/01/20 23:43:52 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 680d4f2..4040f4d 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.58.2.6 2010/01/06 09:30:21 dkf Exp $ + * RCS: @(#) $Id: tkUnixWm.c,v 1.58.2.7 2010/01/20 23:43:52 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 *WmAttributeNames[] = { "-alpha", "-topmost", "-zoomed", "-fullscreen", - NULL + "-type", NULL }; /* @@ -347,6 +347,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 *); @@ -1281,6 +1283,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_OK != Tcl_GetBooleanFromObj(interp, value, &wmPtr->reqState.zoomed)) { @@ -1334,6 +1340,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; } @@ -5333,6 +5341,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 -- @@ -6659,7 +6791,7 @@ TkpMakeMenuWindow( WmInfo *wmPtr; XSetWindowAttributes atts; TkWindow *wrapperPtr; - Atom atom; + Tcl_Obj *typeObj; if (!Tk_HasWrapper(tkwin)) { return; @@ -6672,17 +6804,14 @@ TkpMakeMenuWindow( if (transient) { atts.override_redirect = True; atts.save_under = True; - atom = Tk_InternAtom((Tk_Window) tkwin, "_NET_WM_WINDOW_TYPE_DROPDOWN_MENU"); + typeObj = Tcl_NewStringObj("dropdown_menu", -1); } else { atts.override_redirect = False; atts.save_under = False; - atom = Tk_InternAtom((Tk_Window) tkwin, "_NET_WM_WINDOW_TYPE_MENU"); - TkSetTransientFor(tkwin, NULL); + typeObj = Tcl_NewStringObj("menu", -1); + TkSetTransientFor(tkwin, None); } - 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