TIP #359: Extended window manager hints support for X11.

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  <patthoyts@users.sourceforge.net>
+
+	* 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  <dkf@users.sf.net>
 
 	* 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 <das@users.sourceforge.net>
 # 
-# 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