Index: doc/wm.n ================================================================== --- doc/wm.n +++ doc/wm.n @@ -698,10 +698,36 @@ .QW "no source" as equivalent to \fBprogram\fR. Tk will automatically set the position source to \fBuser\fR when a \fBwm geometry\fR command is invoked, unless the source has been set explicitly to \fBprogram\fR. +.TP +\fBwm property \fIwindow\fR ?\fIname\fR? ?\fIvalue\fR? ?\fItype\fR? ?\fIwidth\fR? +. +This command provides access to the X properties of a Tk toplevel window. +The command is only available on the x11 windowing system. +If \fIname\fR and \fIvalue\fR are specified, the property is updated. The +\fItype\fR and \fIwidth\fR arguments may be used to specify in which format +the property value is to be stored. +Any valid atom name can be used for \fItype\fR. Common values include +\fBSTRING\fR, \fBINTEGER\fR, \fBCARDINAL\fR (i.e. unsigned integer), and +\fBATOM\fR. The special type \fBNone\fR causes the property to be deleted. +The default for \fItype\fR is \fBSTRING\fR. +Note that type names are case sensitive. +Allowed values for \fIwidth\fR are 8, 16, and 32. If omitted, \fIwidth\fR +defaults to 8 for \fBSTRING\fR and \fBUTF8-STRING\fR types, and to 32 for +all other types. +For properties consisting of 8-bit fields, \fIvalue\fR is interpreted as a +byte array. For 16-bit fields it must be specified as a list of integers. +For 32-bit fields, \fIvalue\fR is parsed as a list, where each element may +either be an integer or an atom name. +If \fIname\fR is specified, but no \fIvalue\fR, the current value of the +named property is returned, if set. The type and width of the property value +are returned in the \fB-propertytype\fR and \fB-propertyformat\fR return +options. +If not even the \fIname\fR argument is present, the command returns a list +of the names of all properties that currently exist for the toplevel window. .TP \fBwm protocol \fIwindow\fR ?\fIname\fR? ?\fIcommand\fR? . This command is used to manage window manager protocols. The \fIname\fR argument in the \fBwm protocol\fR command is the name of an atom corresponding Index: tests/wm.test ================================================================== --- tests/wm.test +++ tests/wm.test @@ -120,13 +120,19 @@ test wm-1.1 {Tk_WmObjCmd procedure, miscellaneous errors} -returnCodes error -body { wm } -result {wrong # args: should be "wm option window ?arg ...?"} # Next test will fail every time set of subcommands is changed -test wm-1.2 {Tk_WmObjCmd procedure, miscellaneous errors} -returnCodes error -body { - wm foo -} -result {bad option "foo": must be aspect, attributes, client, colormapwindows, command, deiconify, focusmodel, forget, frame, geometry, grid, group, iconbadge, iconbitmap, iconify, iconmask, iconname, iconphoto, iconposition, iconwindow, manage, maxsize, minsize, overrideredirect, positionfrom, protocol, resizable, sizefrom, stackorder, state, title, transient, or withdraw} +if {[testConstraint x11]} { + test wm-1.2 {Tk_WmObjCmd procedure, miscellaneous errors} -returnCodes error -body { + wm foo + } -result {bad option "foo": must be aspect, attributes, client, colormapwindows, command, deiconify, focusmodel, forget, frame, geometry, grid, group, iconbadge, iconbitmap, iconify, iconmask, iconname, iconphoto, iconposition, iconwindow, manage, maxsize, minsize, overrideredirect, positionfrom, property, protocol, resizable, sizefrom, stackorder, state, title, transient, or withdraw} +} else { + test wm-1.2 {Tk_WmObjCmd procedure, miscellaneous errors} -returnCodes error -body { + wm foo + } -result {bad option "foo": must be aspect, attributes, client, colormapwindows, command, deiconify, focusmodel, forget, frame, geometry, grid, group, iconbadge, iconbitmap, iconify, iconmask, iconname, iconphoto, iconposition, iconwindow, manage, maxsize, minsize, overrideredirect, positionfrom, protocol, resizable, sizefrom, stackorder, state, title, transient, or withdraw} +} test wm-1.3 {Tk_WmObjCmd procedure, miscellaneous errors} -returnCodes error -body { wm command } -result {wrong # args: should be "wm option window ?arg ...?"} test wm-1.4 {Tk_WmObjCmd procedure, miscellaneous errors} -returnCodes error -body { wm aspect bogus @@ -1335,10 +1341,102 @@ } -cleanup { destroy .t2 } -result {user program {}} +### wm property ### +test wm-property-1.1 {usage} -returnCodes error -constraints x11 -body { + wm property +} -result {wrong # args: should be "wm option window ?arg ...?"} +test wm-property-1.2 {usage} -returnCodes error -constraints x11 -body { + wm property .t 1 2 3 4 5 +} -result {wrong # args: should be "wm property window ?name? ?value? ?type? ?width?"} +test wm-property-1.3 {usage} -returnCodes error -constraints x11 -body { + wm property .t _TCL_TEST 42 CARDINAL 24 +} -result {invalid width: 24} +test wm-property-1.4 {usage} -returnCodes error -constraints x11 -body { + wm property .t _TCL_TEST "Some string" STRING 16 +} -result {invalid width: 16} +test wm-property-1.5 {usage} -returnCodes error -constraints x11 -body { + wm property .t _TCL_TEST {invalid "list''} INTEGER 16 +} -result {unmatched open quote in list} +test wm-property-1.6 {usage} -returnCodes error -constraints x11 -body { + wm property .t _TCL_TEST {xx yy zz} INTEGER 16 +} -result {expected integer but got "xx"} +test wm-property-1.7 {usage} -returnCodes error -constraints x11 -body { + wm property .t _TCL_TEST [lrepeat 66 99] INTEGER +} -result {too many elements} +test wm-property-1.8 {usage} -returnCodes error -constraints x11 -body { + wm property .t WM_NAME "New name" +} -result {changing reserved property "WM_NAME" is not allowed} + +test wm-property-2.1 {reading values} -constraints x11 -body { + expr {"WM_NAME" in [wm property .t]} +} -result 1 +test wm-property-2.2 {reading values} -constraints x11 -body { + wm property .t WM_NAME +} -result "t" +test wm-property-2.3 {reading values} -constraints x11 -body { + catch {wm property .t WM_NAME} data opts + dict values [dict filter $opts key -property*] +} -result "STRING 8" +test wm-property-2.4 {reading values} -constraints x11 -body { + catch {wm property .t WM_PROTOCOLS} data opts + dict values [dict filter $opts key -property*] +} -result "ATOM 32" + +test wm-property-3.1 {setting values} -constraints x11 -body { + wm property .t _TCL_TEST "Some string" + catch {wm property .t _TCL_TEST} data opts + linsert [dict values [dict filter $opts key -property*]] 0 $data +} -result {{Some string} STRING 8} +test wm-property-3.2 {setting values} -constraints x11 -body { + wm property .t _TCL_TEST [lrepeat 64 88] CARDINAL + catch {wm property .t _TCL_TEST} data opts + linsert [dict values [dict filter $opts key -property*]] 0 \ + [llength $data] [lsort -unique -integer $data] +} -result {64 88 CARDINAL 32} +test wm-property-3.3 {setting values} -constraints x11 -body { + wm property .t _TCL_TEST {WM_STATE WM_PROTOCOLS _TCL_TEST_ATOM} ATOM + lmap n [wm property .t _TCL_TEST] {winfo atomname $n} +} -result {WM_STATE WM_PROTOCOLS _TCL_TEST_ATOM} + +test wm-property-4.1 {deleting values} -constraints x11 -body { + wm property .t _TCL_TEST "Some string" + wm property .t _TCL_TEST "Delete" None + try {wm property .t _TCL_TEST} on ok {data opts} { + linsert [dict values [dict filter $opts key -property*]] 0 $data + } +} -result {{}} +test wm-property-4.2 {deleting values} -constraints x11 -body { + wm property .t _TCL_TEST_NOTSET "Delete" None + try {wm property .t _TCL_TEST_NOTSET} on ok {data opts} { + linsert [dict values [dict filter $opts key -property*]] 0 $data + } +} -result {{}} + +test wm-property-5.1 {unmapped window} -constraints x11 -body { + toplevel .t1 + wm property .t1 +} -cleanup { + destroy .t1 +} -result {} +test wm-property-5.2 {unmapped window} -constraints x11 -body { + toplevel .t1 + wm property .t1 WM_NAME +} -cleanup { + destroy .t1 +} -result {} +test wm-property-5.3 {unmapped window} -constraints x11 -body { + toplevel .t1 + wm property .t1 _TCL_TEST "Some string" + catch {wm property .t1 _TCL_TEST} data opts + linsert [dict values [dict filter $opts key -property*]] 0 $data +} -cleanup { + destroy .t1 +} -result {{Some string} STRING 8} + ### wm protocol ### test wm-protocol-1.1 {usage} -returnCodes error -body { wm protocol } -result {wrong # args: should be "wm option window ?arg ...?"} test wm-protocol-1.2 {usage} -returnCodes error -body { Index: unix/tkUnixWm.c ================================================================== --- unix/tkUnixWm.c +++ unix/tkUnixWm.c @@ -36,10 +36,12 @@ } ProtocolHandler; #define HANDLER_SIZE(cmdLength) \ (offsetof(ProtocolHandler, command) + 1 + cmdLength) +#define PROPMAXELEMENTS 64 + /* * Data for [wm attributes] command: */ typedef struct { @@ -450,10 +452,13 @@ static int WmOverrideredirectCmd(Tk_Window tkwin, TkWindow *winPtr, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int WmPositionfromCmd(Tk_Window tkwin, TkWindow *winPtr, Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static int WmPropertyCmd(Tk_Window tkwin, TkWindow *winPtr, + Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int WmProtocolCmd(Tk_Window tkwin, TkWindow *winPtr, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int WmResizableCmd(Tk_Window tkwin, TkWindow *winPtr, @@ -1020,11 +1025,11 @@ "aspect", "attributes", "client", "colormapwindows", "command", "deiconify", "focusmodel", "forget", "frame", "geometry", "grid", "group", "iconbadge", "iconbitmap", "iconify", "iconmask", "iconname", "iconphoto", "iconposition", "iconwindow", "manage", "maxsize", - "minsize", "overrideredirect", "positionfrom", + "minsize", "overrideredirect", "positionfrom", "property", "protocol", "resizable", "sizefrom", "stackorder", "state", "title", "transient", "withdraw", NULL }; enum options { WMOPT_ASPECT, WMOPT_ATTRIBUTES, WMOPT_CLIENT, WMOPT_COLORMAPWINDOWS, WMOPT_COMMAND, WMOPT_DEICONIFY, WMOPT_FOCUSMODEL, WMOPT_FORGET, @@ -1031,10 +1036,11 @@ WMOPT_FRAME, WMOPT_GEOMETRY, WMOPT_GRID, WMOPT_GROUP, WMOPT_ICONBADGE, WMOPT_ICONBITMAP, WMOPT_ICONIFY, WMOPT_ICONMASK, WMOPT_ICONNAME, WMOPT_ICONPHOTO, WMOPT_ICONPOSITION, WMOPT_ICONWINDOW, WMOPT_MANAGE, WMOPT_MAXSIZE, WMOPT_MINSIZE, WMOPT_OVERRIDEREDIRECT, WMOPT_POSITIONFROM, + WMOPT_PROPERTY, WMOPT_PROTOCOL, WMOPT_RESIZABLE, WMOPT_SIZEFROM, WMOPT_STACKORDER, WMOPT_STATE, WMOPT_TITLE, WMOPT_TRANSIENT, WMOPT_WITHDRAW }; int index; const char *argv1; TkWindow *winPtr; @@ -1143,10 +1149,12 @@ return WmMinsizeCmd(tkwin, winPtr, interp, objc, objv); case WMOPT_OVERRIDEREDIRECT: return WmOverrideredirectCmd(tkwin, winPtr, interp, objc, objv); case WMOPT_POSITIONFROM: return WmPositionfromCmd(tkwin, winPtr, interp, objc, objv); + case WMOPT_PROPERTY: + return WmPropertyCmd(tkwin, winPtr, interp, objc, objv); case WMOPT_PROTOCOL: return WmProtocolCmd(tkwin, winPtr, interp, objc, objv); case WMOPT_RESIZABLE: return WmResizableCmd(tkwin, winPtr, interp, objc, objv); case WMOPT_SIZEFROM: @@ -3135,10 +3143,219 @@ if (!(wmPtr->flags & WM_NEVER_MAPPED)) { UpdateWmProtocols(wmPtr); } return TCL_OK; } + +/* + *---------------------------------------------------------------------- + * + * WmPropertyCmd -- + * + * This function is invoked to process the "wm property" Tcl command. See + * the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +static int +WmPropertyCmd( + TCL_UNUSED(Tk_Window), /* Main window of the application. */ + TkWindow *winPtr, /* Toplevel to work with */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + WmInfo *wmPtr = winPtr->wmInfoPtr; + Atom property, type = XA_STRING; + Atom XA_UTF8_STRING = Tk_InternAtom((Tk_Window)winPtr, "UTF8_STRING"); + int i, count, value, width = 0; + const char *name; + const unsigned char *bytes; + unsigned char data8[PROPMAXELEMENTS * sizeof(long)]; + unsigned short *data16; + unsigned long *data32; + Tcl_Size length; + Tcl_Obj **elements; + + if ((objc < 3) || (objc > 7)) { + Tcl_WrongNumArgs(interp, 2, objv, + "window ?name? ?value? ?type? ?width?"); + return TCL_ERROR; + } + if (objc == 3) { + /* + * Return a list of all defined properties for the window. + */ + Tcl_Obj *resultObj = Tcl_NewObj(); + Atom *atoms; + + if (wmPtr->wrapperPtr != NULL) { + atoms = XListProperties(wmPtr->wrapperPtr->display, + wmPtr->wrapperPtr->window, &count); + } else { + count = 0; + } + + for (i = 0; i < count; i++) { + Tcl_ListObjAppendElement(NULL, resultObj, + Tcl_NewStringObj(Tk_GetAtomName((Tk_Window)winPtr, + atoms[i]), -1)); + } + Tcl_SetObjResult(interp, resultObj); + return TCL_OK; + } + + name = Tcl_GetString(objv[3]); + property = Tk_InternAtom((Tk_Window)winPtr, name); + + if (objc == 4) { + /* + * Return the value of a given property. + */ + + int format; + unsigned long nitems, remain; + unsigned char *data; + long maxLength = PROPMAXELEMENTS; + + if (wmPtr->wrapperPtr == NULL) return TCL_OK; + + if (GetWindowProperty(wmPtr->wrapperPtr, property, maxLength, + AnyPropertyType, &type, &format, &nitems, &remain, &data)) { + Tcl_Obj *options = Tcl_NewDictObj(); + Tcl_Obj *resultObj; + const char *typeStr; + + count = nitems; + switch (format) { + case 8: + Tcl_SetObjResult(interp, Tcl_NewByteArrayObj(data, count)); + break; + case 16: + data16 = (unsigned short *)data; + resultObj = Tcl_NewListObj(count, NULL); + for (i = 0; i < count; i++) { + Tcl_ListObjAppendElement(NULL, resultObj, + Tcl_NewIntObj(data16[i])); + } + Tcl_SetObjResult(interp, resultObj); + break; + case 32: + data32 = (unsigned long *)data; + resultObj = Tcl_NewListObj(count, NULL); + for (i = 0; i < count; i++) { + Tcl_ListObjAppendElement(NULL, resultObj, + Tcl_NewIntObj(data32[i])); + } + Tcl_SetObjResult(interp, resultObj); + break; + } + XFree(data); + if (type != None) { + typeStr = Tk_GetAtomName((Tk_Window)winPtr, type); + Tcl_DictObjPut(NULL, options, + Tcl_NewStringObj("-propertytype", -1), + Tcl_NewStringObj(typeStr, -1)); + Tcl_DictObjPut(NULL, options, + Tcl_NewStringObj("-propertyformat", -1), Tcl_NewIntObj(format)); + Tcl_SetReturnOptions(interp, options); + } + } + return TCL_OK; + } + + /* Properties starting with WM_ or _NET_WM_ are considered reserved */ + /* Those properties may only be changed using dedicated wm commands */ + if (strncmp(name, "WM_", 3) == 0 || strncmp(name, "_NET_WM_", 8) == 0) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf("changing reserved property " + "\"%s\" is not allowed", name)); + return TCL_ERROR; + } + + if (objc >= 6) { + if (strcmp(Tcl_GetString(objv[5]), "None") == 0) { + /* Delete the property */ + if (wmPtr->wrapperPtr != NULL) { + XDeleteProperty(wmPtr->wrapperPtr->display, + wmPtr->wrapperPtr->window, property); + } + return TCL_OK; + } + type = Tk_InternAtom((Tk_Window)winPtr, Tcl_GetString(objv[5])); + } + + if (objc >= 7) { + if (Tcl_GetIntFromObj(interp, objv[6], &width) != TCL_OK) { + return TCL_ERROR; + } + } + + if (width == 0) { + width = type == XA_STRING || type == XA_UTF8_STRING ? 8 : 32; + } + + if ((width != 8 && width != 16 && width != 32) + || ((type == XA_ATOM || type == XA_BITMAP) && width != 32) + || ((type == XA_STRING || type == XA_UTF8_STRING) && width != 8)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf("invalid width: %d", width)); + return TCL_ERROR; + } + + switch (width) { + case 8: + bytes = Tcl_GetByteArrayFromObj(objv[4], &length); + if (length <= PROPMAXELEMENTS) { + memcpy(data8, bytes, length); + } + break; + case 16: + data16 = (unsigned short *) data8; + if (Tcl_ListObjGetElements(interp, objv[4], + &length, &elements) != TCL_OK) return TCL_ERROR; + if (length <= PROPMAXELEMENTS) { + for (i = 0; i < length; i++) { + if (Tcl_GetIntFromObj(interp, elements[i], &value) != TCL_OK) { + return TCL_ERROR; + } + data16[i] = value; + } + } + break; + case 32: + data32 = (unsigned long *) data8; + if (Tcl_ListObjGetElements(interp, objv[4], + &length, &elements) != TCL_OK) return TCL_ERROR; + if (length <= PROPMAXELEMENTS) { + for (i = 0; i < length; i++) { + if (Tcl_GetIntFromObj(NULL, elements[i], &value) != TCL_OK) { + data32[i] = Tk_InternAtom((Tk_Window)winPtr, + Tcl_GetString(elements[i])); + } else { + data32[i] = value; + } + } + } + } + + if (length > PROPMAXELEMENTS) { + Tcl_SetObjResult(interp, Tcl_NewStringObj("too many elements", -1)); + return TCL_ERROR; + } + + /* Create the wrapper window, if necessary */ + if (wmPtr->wrapperPtr == NULL) CreateWrapper(wmPtr); + /* Create or update the property */ + SetWindowProperty(wmPtr->wrapperPtr, name, type, width, data8, length); + return TCL_OK; +} /* *---------------------------------------------------------------------- * * WmResizableCmd --