Tk Source Code

2010-01-23  Pat Thoyts  <[email protected]>

	* 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  <[email protected]>

	* library/tk.tcl (::tk::ScreenChanged): [Bug 2912473]: Stop problems
	caused by display names with a double colon in.

2009-11-01  Joe Mistachkin  <[email protected]>

# bgerror.tcl --
#
#	Implementation of the bgerror procedure.  It posts a dialog box with
#	the error message and gives the user a chance to see a more detailed
#	stack trace, and possible do something more interesting with that
#	trace (like save it to a log).  This is adapted from work done by
#	Donal K. Fellows.
#
# Copyright (c) 1998-2000 by Ajuba Solutions.
# Copyright (c) 2007 Daniel A. Steffen <[email protected]>
# 
# 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::*
    namespace export bgerror
    option add *ErrorDialog.function.text [mc "Save To Log"] \
	widgetDefault
    option add *ErrorDialog.function.command [namespace code SaveToLog]

    wm title .bgerrorDialog $title
    wm iconname .bgerrorDialog ErrorDialog
    wm protocol .bgerrorDialog WM_DELETE_WINDOW { }

    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
    frame .bgerrorDialog.top
    if {$windowingsystem eq "x11"} {
	.bgerrorDialog.bot configure -relief raised -bd 1
	.bgerrorDialog.top configure -relief raised -bd 1

# clrpick.tcl --
#
#	Color selection dialog for platforms that do not support a
#	standard color selection dialog.
#
# RCS: @(#) $Id: clrpick.tcl,v 1.20.2.3 2010/01/23 01:36:03 patthoyts Exp $
#
# Copyright (c) 1996 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# ToDo:

    set sc [winfo screen $data(-parent)]
    set winExists [winfo exists $w]
    if {!$winExists || $sc ne [winfo screen $w]} {
	if {$winExists} {
	    destroy $w
	}
	toplevel $w -class TkColorDialog -screen $sc
	if {[tk windowingsystem] eq "x11"} {wm attributes $w -type dialog}
	BuildDialog $w
    }

    # Dialog boxes should be transient with respect to their parent,
    # so that they will always stay on top of their parent window.  However,
    # some window managers will create the window as withdrawn if the parent
    # window is withdrawn or iconified.  Combined with the grab we put on the

# dialog.tcl --
#
# 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.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.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#

    #
    if {[winfo viewable [winfo toplevel [winfo parent $w]]] } {
	wm transient $w [winfo toplevel [winfo parent $w]]
    }

    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
    frame $w.top
    if {$windowingsystem eq "x11"} {
	$w.bot configure -relief raised -bd 1
	$w.top configure -relief raised -bd 1

# msgbox.tcl --
#
#	Implements messageboxes for platforms that do not have native
#	messagebox support.
#
# RCS: @(#) $Id: msgbox.tcl,v 1.24.2.5 2010/01/23 01:36:03 patthoyts Exp $
#
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#

    #
    if {[winfo viewable [winfo toplevel $data(-parent)]] } {
	wm transient $w $data(-parent)
    }    

    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
    pack $w.bot -side bottom -fill both
    frame $w.top -background $bg
    pack $w.top -side top -fill both -expand 1
    if {$windowingsystem ne "classic" && $windowingsystem ne "aqua"} {

# tkfbox.tcl --
#
#	Implements the "TK" standard file selection dialog box. This
#	dialog box is used on the Unix platforms whenever the tk_strictMotif
#	flag is not set.
#
#	The "TK" standard file selection dialog box is similar to the
#	file selection dialog box on Win95(TM). The user can navigate
#	the directories by clicking on the folder icons or by
#	selecting the "Directory" option menu. The user can select
#	files by clicking on the file icons or by entering a filename
#	in the "Filename:" entry.
#
# RCS: @(#) $Id: tkfbox.tcl,v 1.38.2.14 2010/01/23 01:36:03 patthoyts Exp $
#
# Copyright (c) 1994-1998 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#

proc ::tk::dialog::file::Create {w class} {
    set dataName [lindex [split $w .] end]
    upvar ::tk::dialog::file::$dataName data
    variable ::tk::Priv
    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
    #
    set f1 [frame $w.f1]
    bind [::tk::AmpWidget label $f1.lab -text "[mc "&Directory:"]" ] \
	<<AltUnderlined>> [list focus $f1.menu]
    

# This file is a Tcl script to test out Tk's interactions with
# the window manager, including the "wm" command.  It is organized
# in the standard fashion for Tcl tests.
#
# Copyright (c) 1992-1994 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
# 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
namespace import -force tcltest::testsDirectory
configure -testdir [file join [pwd] [file dirname [info script]]]
configure -loadfile [file join [testsDirectory] constraints.tcl]
tcltest::loadTestedCommands

    list $error $msg
} {0 {}}

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 ?-type list?"}}

test unixWm-61.1 {Tk_WmCmd procedure, "iconphoto" option} unix {
    list [catch {wm iconph .} msg] $msg
} {1 {wrong # args: should be "wm iconphoto window ?-default? image1 ?image2 ...?"}}
test unixWm-61.2 {Tk_WmCmd procedure, "iconphoto" option} unix {
    destroy .t
    toplevel .t
    image create photo blank16 -width 16 -height 16
    image create photo blank32 -width 32 -height 32
    # This should just make blank icons for the window
    wm iconphoto .t blank16 blank32
    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
return

 *
 * Copyright (c) 1991-1994 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 *
 * 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.8 2010/01/23 01:36:03 patthoyts Exp $
 */

#include "tkPort.h"
#include "tkInt.h"
#include "tkUnixInt.h"

/*

			    int *maxWidthPtr, int *maxHeightPtr));
static void		MenubarDestroyProc _ANSI_ARGS_((ClientData clientData,
			    XEvent *eventPtr));
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,
			    Tcl_HashTable *reparentTable));
static void		TopLevelReqProc _ANSI_ARGS_((ClientData dummy,
			    Tk_Window tkwin));
static void		UpdateCommand _ANSI_ARGS_((TkWindow *winPtr));

WmAttributesCmd(tkwin, winPtr, interp, objc, objv)
    Tk_Window tkwin;		/* 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. */
{
    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;
    }
    if (objc == 4) {
	Tcl_SetObjResult(interp, GetNetWmType(winPtr));
	return TCL_OK;
    }
    return SetNetWmType(winPtr, objv[4]);
}

/*
 *----------------------------------------------------------------------
 *
 * WmClientCmd --
 *

    WmInfo *wmPtr = winPtr->wmInfoPtr;

    if (wmPtr->flags & WM_NEVER_MAPPED) {
	return;
    }
    XSetWMHints(winPtr->display, wmPtr->wrapperPtr->window, &wmPtr->hints);
}

/*
 *----------------------------------------------------------------------
 *
 * 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 --
 *
 *	This procedure parses a geometry string and updates

	*maxHeightPtr = tmp;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * 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)
 *	menu, or as a toplevel (torn-off) menu or palette.
 *
 * Results:
 *	None.

				 * menu is always visible, e.g. as a torn-off
				 * menu.  Determines whether save_under and
				 * override_redirect should be set. */
{
    WmInfo *wmPtr;
    XSetWindowAttributes atts;
    TkWindow *wrapperPtr;
    Tcl_Obj *typeObj;

    if (!Tk_HasWrapper(tkwin)) {
	return;
    }
    wmPtr = ((TkWindow *) tkwin)->wmInfoPtr;
    if (wmPtr->wrapperPtr == NULL) {
	CreateWrapper(wmPtr);
    }
    wrapperPtr = wmPtr->wrapperPtr;
    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
     * wrapper window in order to have the desired effect.  However,
     * also set the override-redirect bit on the window itself, so
     * that the "wm overrideredirect" command will see it.
     */