From cd994d3ced67041b075edf76bd0d3bb9adaf05cb Mon Sep 17 00:00:00 2001
From: Pat Thoyts <patthoyts@users.sourceforge.net>
Date: Mon, 21 Dec 2009 21:07:05 +0000
Subject: [PATCH] ewmh: Add support for extended window manager hints.
 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.

The window type can be set to a list of type preferences to permit
currently unknown types to be used in the future. The final item in
the list should be one of the types listed in the EWMH specification.

Signed-off-by: Pat Thoyts <patthoyts@users.sourceforge.net>
---
 library/bgerror.tcl      |    1 +
 library/clrpick.tcl      |    1 +
 library/demos/widget     |    2 +
 library/dialog.tcl       |    1 +
 library/msgbox.tcl       |    1 +
 library/tkfbox.tcl       |    1 +
 library/ttk/combobox.tcl |    2 +
 unix/tkUnixWm.c          |  144 ++++++++++++++++++++++++++++++++++++++++++---
 8 files changed, 143 insertions(+), 10 deletions(-)

diff --git a/library/bgerror.tcl b/library/bgerror.tcl
index 11d2d42..e4f0020 100644
--- a/library/bgerror.tcl
+++ b/library/bgerror.tcl
@@ -139,6 +139,7 @@ proc ::tk::dialog::error::bgerror err {
     wm title $dlg $title
     wm iconname $dlg ErrorDialog
     wm protocol $dlg WM_DELETE_WINDOW { }
+    wm attributes $dlg -type dialog
 
     if {$windowingsystem eq "aqua"} {
 	::tk::unsupported::MacWindowStyle style $dlg moveableAlert {}
diff --git a/library/clrpick.tcl b/library/clrpick.tcl
index 976aa81..6abfe17 100644
--- a/library/clrpick.tcl
+++ b/library/clrpick.tcl
@@ -74,6 +74,7 @@ proc ::tk::dialog::color:: {args} {
 	    destroy $w
 	}
 	toplevel $w -class TkColorDialog -screen $sc
+        wm attributes $w -type dialog
 	BuildDialog $w
     }
 
diff --git a/library/demos/widget b/library/demos/widget
index d6345bc..c3b21bd 100644
--- a/library/demos/widget
+++ b/library/demos/widget
@@ -471,6 +471,7 @@ proc positionWindow w {
 proc showVars {w args} {
     catch {destroy $w}
     toplevel $w
+    wm attributes $w -type dialog
     wm title $w [mc "Variable values"]
 
     set b [ttk::frame $w.frame]
@@ -572,6 +573,7 @@ proc showCode w {
     set top .code
     if {![winfo exists $top]} {
 	toplevel $top
+        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 a7de0c9..8967d96 100644
--- a/library/dialog.tcl
+++ b/library/dialog.tcl
@@ -57,6 +57,7 @@ proc ::tk_dialog {w title text bitmap default args} {
 
     destroy $w
     toplevel $w -class Dialog
+    wm attributes $w -type dialog
     wm title $w $title
     wm iconname $w Dialog
     wm protocol $w WM_DELETE_WINDOW { }
diff --git a/library/msgbox.tcl b/library/msgbox.tcl
index 53a8889..91ecaa6 100644
--- a/library/msgbox.tcl
+++ b/library/msgbox.tcl
@@ -254,6 +254,7 @@ proc ::tk::MessageBox {args} {
 
     catch {destroy $w}
     toplevel $w -class Dialog -bg $bg
+    wm attributes $w -type dialog
     wm title $w $data(-title)
     wm iconname $w Dialog
     wm protocol $w WM_DELETE_WINDOW { }
diff --git a/library/tkfbox.tcl b/library/tkfbox.tcl
index 98b4bf4..b76bc7b 100644
--- a/library/tkfbox.tcl
+++ b/library/tkfbox.tcl
@@ -1047,6 +1047,7 @@ proc ::tk::dialog::file::Create {w class} {
     global tk_library
 
     toplevel $w -class $class
+    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 bade497..f276bec 100644
--- a/library/ttk/combobox.tcl
+++ b/library/ttk/combobox.tcl
@@ -266,6 +266,7 @@ proc ttk::combobox::PopdownWindow {cb} {
 
     if {![winfo exists $cb.popdown]} {
 	set popdown [PopdownToplevel $cb.popdown]
+        wm attributes $popdown -type combo
 
 	$scrollbar $popdown.sb \
 	    -orient vertical -command [list $popdown.l yview]
@@ -293,6 +294,7 @@ proc ttk::combobox::PopdownWindow {cb} {
 #
 proc ttk::combobox::PopdownToplevel {w} {
     toplevel $w -class ComboboxPopdown
+    wm attributes $w -type combo
     wm withdraw $w
     switch -- [tk windowingsystem] {
 	default -
diff --git a/unix/tkUnixWm.c b/unix/tkUnixWm.c
index 2c2d343..cee6115 100644
--- a/unix/tkUnixWm.c
+++ b/unix/tkUnixWm.c
@@ -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 *);
@@ -1277,6 +1279,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)) {
@@ -1330,6 +1336,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;
     }
@@ -5329,6 +5337,125 @@ 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 = winPtr->wmInfoPtr->wrapperPtr;
+    Tcl_Obj *typePtr;
+    Tcl_Interp *interp;
+    Tcl_DString ds;
+
+    interp = Tk_Interp(tkwin);
+    typePtr = Tcl_NewListObj(0, NULL);
+
+    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 --
@@ -6655,7 +6782,7 @@ TkpMakeMenuWindow(
     WmInfo *wmPtr;
     XSetWindowAttributes atts;
     TkWindow *wrapperPtr;
-    Atom atom;
+    Tcl_Obj *typeObj;
 
     if (!Tk_HasWrapper(tkwin)) {
 	return;
@@ -6668,17 +6795,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
-- 
1.6.2

