TIP #359: Extended Window Manager Hints support for 8.4

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