Tk Source Code

2012-02-15  Jan Nijtmans  <[email protected]>

	* xlib/xcolors.c: [Bug 3486474]: Inconsistent color scaling
	* generic/tkColor.c: new internal function TkParseColor
	* generic/tkInt.h:
	* generic/tk*.c:   Change XParseColor() to TkParseColor() everywhere.

/*
 * The following structure is used by the new Tk_ChooseDirectoryObjCmd to pass
 * data between it and its callback. Unique to Windows platform.
 */

typedef struct ChooseDirData {
   char utfInitDir[MAX_PATH];	/* Initial folder to use */
   char utfRetDir[MAX_PATH];	/* Returned folder to use */
   Tcl_Interp *interp;
   int mustExist;		/* True if file must exist to return from
				 * callback */
} CHOOSEDIRDATA;

typedef struct ThreadSpecificData {
    int debugFlag;		/* Flags whether we should output debugging

static int 		MakeFilter(Tcl_Interp *interp, Tcl_Obj *valuePtr,
			    Tcl_DString *dsPtr, Tcl_Obj *initialPtr,
			    int *indexPtr);
static UINT APIENTRY	OFNHookProc(HWND hdlg, UINT uMsg, WPARAM wParam,
			    LPARAM lParam);
static LRESULT CALLBACK MsgBoxCBTProc(int nCode, WPARAM wParam, LPARAM lParam);
static void		SetTkDialog(ClientData clientData);
static char *		ConvertExternalFilename(Tcl_Encoding encoding,
			    char *filename, Tcl_DString *dsPtr);

/*
 *-------------------------------------------------------------------------
 *
 * EatSpuriousMessageBugFix --
 *
 *	In the file open/save dialog, double clicking on a list item causes

    int inValue, confirmOverwrite = 1;
    const char *extension = NULL, *title = NULL;
    Tk_Window tkwin = clientData;
    HWND hWnd;
    Tcl_Obj *filterObj = NULL, *initialTypeObj = NULL, *typeVariableObj = NULL;
    Tcl_DString utfFilterString, utfDirString, ds;
    Tcl_DString extString, filterString, dirString, titleString;
    Tcl_Encoding unicodeEncoding = TkWinGetUnicodeEncoding();
    ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
	    Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));
    static const char *const saveOptionStrings[] = {
	"-defaultextension", "-filetypes", "-initialdir", "-initialfile",
	"-parent", "-title", "-typevariable",
	"-confirmoverwrite",
	NULL

		goto end;
	    }
	    break;
	case FILE_INITFILE:
	    if (Tcl_TranslateFileName(interp, string, &ds) == NULL) {
		goto end;
	    }
	    Tcl_UtfToExternal(NULL, unicodeEncoding, Tcl_DStringValue(&ds),
		    Tcl_DStringLength(&ds), 0, NULL, (char *) file,
		    sizeof(file), NULL, NULL, NULL);
	    Tcl_DStringFree(&ds);
	    break;
	case FILE_PARENT:
	    tkwin = Tk_NameToWindow(interp, string, tkwin);
	    if (tkwin == NULL) {

	 */

	ofnData.dynFileBufferSize = 512;
	ofnData.dynFileBuffer = ckalloc(512 * sizeof(TCHAR));
    }

    if (extension != NULL) {
	Tcl_UtfToExternalDString(unicodeEncoding, extension, -1, &extString);
	ofn.lpstrDefExt = (TCHAR *) Tcl_DStringValue(&extString);
    }

    Tcl_UtfToExternalDString(unicodeEncoding,
	    Tcl_DStringValue(&utfFilterString),
	    Tcl_DStringLength(&utfFilterString), &filterString);
    ofn.lpstrFilter = (TCHAR *) Tcl_DStringValue(&filterString);
    ofn.nFilterIndex = filterIndex;

    if (Tcl_DStringValue(&utfDirString)[0] != '\0') {
	Tcl_UtfToExternalDString(unicodeEncoding,
		Tcl_DStringValue(&utfDirString),
		Tcl_DStringLength(&utfDirString), &dirString);
    } else {
	/*
	 * NT 5.0 changed the meaning of lpstrInitialDir, so we have to ensure
	 * that we set the [pwd] if the user didn't specify anything else.
	 */

	Tcl_DString cwd;

	Tcl_DStringFree(&utfDirString);
	if ((Tcl_GetCwd(interp, &utfDirString) == NULL) ||
		(Tcl_TranslateFileName(interp,
			Tcl_DStringValue(&utfDirString), &cwd) == NULL)) {
	    Tcl_ResetResult(interp);
	} else {
	    Tcl_UtfToExternalDString(unicodeEncoding, Tcl_DStringValue(&cwd),
		    Tcl_DStringLength(&cwd), &dirString);
	}
	Tcl_DStringFree(&cwd);
    }
    ofn.lpstrInitialDir = (TCHAR *) Tcl_DStringValue(&dirString);

    if (title != NULL) {
	Tcl_UtfToExternalDString(unicodeEncoding, title, -1, &titleString);
	ofn.lpstrTitle = (TCHAR *) Tcl_DStringValue(&titleString);
    }

    /*
     * Popup the dialog.
     */

	    Tcl_Obj *returnList = Tcl_NewObj();
	    int count = 0;

	    /*
	     * Get directory.
	     */

	    (void) ConvertExternalFilename(unicodeEncoding, (char *) files,
		    &ds);

	    while (*files != '\0') {
		while (*files != '\0') {
		    files++;
		}
		files++;
		if (*files != '\0') {
		    Tcl_Obj *fullnameObj;
		    Tcl_DString filenameBuf;

		    count++;
		    (void) ConvertExternalFilename(unicodeEncoding,
			    (char *) files, &filenameBuf);

		    fullnameObj = Tcl_NewStringObj(Tcl_DStringValue(&ds),
			    Tcl_DStringLength(&ds));
		    Tcl_AppendToObj(fullnameObj, "/", -1);
		    Tcl_AppendToObj(fullnameObj, Tcl_DStringValue(&filenameBuf),
			    Tcl_DStringLength(&filenameBuf));
		    gotFilename = 1;

			Tcl_NewStringObj(Tcl_DStringValue(&ds),
				Tcl_DStringLength(&ds)));
		gotFilename |= (Tcl_DStringLength(&ds) > 0);
	    }
	    Tcl_SetObjResult(interp, returnList);
	    Tcl_DStringFree(&ds);
	} else {
	    Tcl_AppendResult(interp, ConvertExternalFilename(unicodeEncoding,
		    (char *) ofn.lpstrFile, &ds), NULL);
	    gotFilename = (Tcl_DStringLength(&ds) > 0);
	    Tcl_DStringFree(&ds);
	}
	result = TCL_OK;
	if ((ofn.nFilterIndex > 0) && gotFilename && typeVariableObj
		&& filterObj) {
	    int listObjc, count;

	    } else if (Tcl_ObjSetVar2(interp, typeVariableObj, NULL,
		    typeInfo[0], TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) {
		result = TCL_ERROR;
	    }
	}
    } else if (cdlgerr == FNERR_INVALIDFILENAME) {
	Tcl_SetResult(interp, "invalid filename \"", TCL_STATIC);
	Tcl_AppendResult(interp, ConvertExternalFilename(unicodeEncoding,
		(char *) ofn.lpstrFile, &ds), "\"", NULL);
	Tcl_DStringFree(&ds);
    } else {
	result = TCL_OK;
    }

    if (ofn.lpstrTitle != NULL) {
	Tcl_DStringFree(&titleString);

		 * every second quote to NULL terminator
		 */

		if (buffer[0] == '"') {
		    BOOL findquote = TRUE;
		    TCHAR *tmp = buffer;

		    while(*buffer != '\0') {
			if (findquote) {
			    if (*buffer == '"') {
				findquote = FALSE;
			    }
			    buffer++;
			} else {
			    if (*buffer == '"') {

int
Tk_ChooseDirectoryObjCmd(
    ClientData clientData,	/* Main window associated with interpreter. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    char path[MAX_PATH];
    int oldMode, result = TCL_ERROR, i;
    LPCITEMIDLIST pidl;		/* Returned by browser */
    BROWSEINFOA bInfo;		/* Used by browser */
    CHOOSEDIRDATA cdCBData;	/* Structure to pass back and forth */
    LPMALLOC pMalloc;		/* Used by shell */
    Tk_Window tkwin = clientData;
    HWND hWnd;
    const char *utfTitle = NULL;/* Title for window */
    char saveDir[MAX_PATH];
    Tcl_DString titleString;	/* UTF Title */
    Tcl_DString initDirString;	/* Initial directory */

    Tcl_Obj *objPtr;
    static const char *const optionStrings[] = {
	"-initialdir", "-mustexist",  "-parent",  "-title", NULL
    };
    enum options {
	DIR_INITIAL,   DIR_EXIST,  DIR_PARENT, FILE_TITLE
    };

    /*
     * Process the command line options
     */

    for (i = 1; i < objc; i += 2) {
	int index;
	const char *string;

	Tcl_Obj *optionPtr, *valuePtr;

	optionPtr = objv[i];
	valuePtr = objv[i + 1];

	if (Tcl_GetIndexFromObj(interp, optionPtr, optionStrings, "option", 0,
		&index) != TCL_OK) {

	string = Tcl_GetString(valuePtr);
	switch ((enum options) index) {
	case DIR_INITIAL:
	    if (Tcl_TranslateFileName(interp,string,&initDirString) == NULL) {
		goto cleanup;
	    }
	    string = Tcl_DStringValue(&initDirString);


	    /*
	     * Convert possible relative path to full path to keep dialog
	     * happy.
	     */

	    GetFullPathNameA(string, MAX_PATH, saveDir, NULL);
	    lstrcpynA(cdCBData.utfInitDir, saveDir, MAX_PATH);
	    Tcl_DStringFree(&initDirString);

	    break;
	case DIR_EXIST:
	    if (Tcl_GetBooleanFromObj(interp, valuePtr,
		    &cdCBData.mustExist) != TCL_OK) {
		goto cleanup;
	    }
	    break;

    /*
     * Setup the parameters used by SHBrowseForFolder
     */

    bInfo.hwndOwner = hWnd;
    bInfo.pszDisplayName = path;
    bInfo.pidlRoot = NULL;
    if (lstrlenA(cdCBData.utfInitDir) == 0) {
	GetCurrentDirectoryA(MAX_PATH, cdCBData.utfInitDir);
    }
    bInfo.lParam = (LPARAM) &cdCBData;

    if (utfTitle != NULL) {
	Tcl_UtfToExternalDString(NULL, utfTitle, -1, &titleString);
	bInfo.lpszTitle = (LPSTR) Tcl_DStringValue(&titleString);
    } else {
	bInfo.lpszTitle = "Please choose a directory, then select OK.";
    }

    /*
     * Set flags to add edit box, status text line and use the new ui. Allow
     * override with magic variable (ignore errors in retrieval). See
     * http://msdn.microsoft.com/en-us/library/bb773205(VS.85).aspx for
     * possible flag values.

    /*
     * Display dialog in background and process result. We look to give the
     * user a chance to change their mind on an invalid folder if mustexist is
     * 0.
     */

    oldMode = Tcl_SetServiceMode(TCL_SERVICE_ALL);
    GetCurrentDirectoryA(MAX_PATH, saveDir);
    if (SHGetMalloc(&pMalloc) == NOERROR) {
	pidl = SHBrowseForFolderA(&bInfo);

	/*
	 * This is a fix for Windows 2000, which seems to modify the folder name
	 * buffer even when the dialog is canceled (in this case the buffer
	 * contains garbage). See [Bug #3002230]
	 */
	path[0] = '\0';

	/*
	 * Null for cancel button or invalid dir, otherwise valid.
	 */

	if (pidl != NULL) {
	    if (!SHGetPathFromIDListA(pidl, path)) {
		Tcl_SetResult(interp, "Error: Not a file system folder\n",
			TCL_VOLATILE);
	    };
	    pMalloc->lpVtbl->Free(pMalloc, (void *) pidl);
	} else if (lstrlenA(cdCBData.utfRetDir) > 0) {
	    lstrcpyA(path, cdCBData.utfRetDir);
	}
	pMalloc->lpVtbl->Release(pMalloc);
    }
    SetCurrentDirectoryA(saveDir);
    Tcl_SetServiceMode(oldMode);

    /*
     * Ensure that hWnd is enabled, because it can happen that we have updated
     * the wrapper of the parent, which causes us to leave this child disabled
     * (Windows loses sync).
     */

    EnableWindow(hWnd, 1);

    /*
     * Change the pathname to the Tcl "normalized" pathname, where back
     * slashes are used instead of forward slashes
     */

    Tcl_ResetResult(interp);
    if (*path) {
	Tcl_DString ds;

	Tcl_AppendResult(interp, ConvertExternalFilename(NULL, (char *) path,
		&ds), NULL);
	Tcl_DStringFree(&ds);
    }

    result = TCL_OK;

    if (utfTitle != NULL) {
	Tcl_DStringFree(&titleString);

static UINT APIENTRY
ChooseDirectoryValidateProc(
    HWND hwnd,
    UINT message,
    LPARAM lParam,
    LPARAM lpData)
{
    char selDir[MAX_PATH];
    CHOOSEDIRDATA *chooseDirSharedData = (CHOOSEDIRDATA *) lpData;

    Tcl_DString initDirString;
    char string[MAX_PATH];
    ThreadSpecificData *tsdPtr =
	    Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));

    if (tsdPtr->debugFlag) {
	tsdPtr->debugInterp = (Tcl_Interp *) chooseDirSharedData->interp;
	Tcl_DoWhenIdle(SetTkDialog, hwnd);
    }
    chooseDirSharedData->utfRetDir[0] = '\0';
    switch (message) {
    case BFFM_VALIDATEFAILED:
	/*
	 * First save and check to see if it is a valid path name, if so then
	 * make that path the one shown in the window. Otherwise, it failed
	 * the check and should be treated as such. Use
	 * Set/GetCurrentDirectoryA which allows relative path names and names
	 * with forward slashes. Use Tcl_TranslateFileName to make sure names
	 * like ~ are converted correctly.
	 */


	if (Tcl_TranslateFileName(chooseDirSharedData->interp,
		(char *) lParam, &initDirString) == NULL) {
	    /*
	     * Should we expose the error (in the interp result) to the user
	     * at this point?
	     */

	    chooseDirSharedData->utfRetDir[0] = '\0';
	    return 1;
	}



	lstrcpynA(string, Tcl_DStringValue(&initDirString), MAX_PATH);
	Tcl_DStringFree(&initDirString);

	if (SetCurrentDirectoryA((char *)string) == 0) {
	    LPSTR lpFilePart[MAX_PATH];

	    /*
	     * Get the full path name to the user entry, at this point it does
	     * not exist so see if it is supposed to. Otherwise just return
	     * it.
	     */

	    GetFullPathNameA(string, MAX_PATH,
		    chooseDirSharedData->utfRetDir, /*unused*/ lpFilePart);
	    if (chooseDirSharedData->mustExist) {
		/*
		 * User HAS to select a valid directory.
		 */

		wsprintfA(selDir, "Directory '%.200s' does not exist,\nplease select or enter an existing directory.", chooseDirSharedData->utfRetDir);
		MessageBoxA(NULL, selDir, NULL, MB_ICONEXCLAMATION|MB_OK);
		chooseDirSharedData->utfRetDir[0] = '\0';
		return 1;
	    }
	} else {
	    /*
	     * Changed to new folder OK, return immediatly with the current
	     * directory in utfRetDir.
	     */

	    GetCurrentDirectoryA(MAX_PATH, chooseDirSharedData->utfRetDir);
	    return 0;
	}
	return 0;

    case BFFM_SELCHANGED:
	/*
	 * Set the status window to the currently selected path and enable the
	 * OK button if a file system folder, otherwise disable the OK button
	 * for things like server names. Perhaps a new switch
	 * -enablenonfolders can be used to allow non folders to be selected.
	 *
	 * Not called when user changes edit box directly.
	 */

	if (SHGetPathFromIDListA((LPITEMIDLIST) lParam, selDir)) {
	    SendMessageA(hwnd, BFFM_SETSTATUSTEXT, 0, (LPARAM) selDir);
	    // enable the OK button
	    SendMessageA(hwnd, BFFM_ENABLEOK, 0, (LPARAM) 1);
	} else {
	    // disable the OK button
	    SendMessageA(hwnd, BFFM_ENABLEOK, 0, (LPARAM) 0);
	}
	UpdateWindow(hwnd);
	return 1;

    case BFFM_INITIALIZED: {
	/*
	 * Directory browser intializing - tell it where to start from, user
	 * specified parameter.
	 */

	char *initDir = chooseDirSharedData->utfInitDir;

	Tcl_DString initDirDStr;
	Tcl_UtfToExternalDString(TkWinGetUnicodeEncoding(), initDir, -1, &initDirDStr);
	SetCurrentDirectoryA(Tcl_DStringValue(&initDirDStr));
	
	if (*initDir == '\\') {
	    /*
	     * BFFM_SETSELECTION only understands UNC paths as pidls, so
	     * convert path to pidl using IShellFolder interface.
	     */

	    LPMALLOC pMalloc;
	    LPSHELLFOLDER psfFolder;

	    if (SUCCEEDED(SHGetMalloc(&pMalloc))) {
		if (SUCCEEDED(SHGetDesktopFolder(&psfFolder))) {
		    LPITEMIDLIST pidlMain;
		    ULONG ulCount, ulAttr;

		    if (SUCCEEDED(psfFolder->lpVtbl->ParseDisplayName(
			    psfFolder, hwnd, NULL, (TCHAR *)
			    Tcl_DStringValue(&initDirDStr), &ulCount,&pidlMain,&ulAttr))
			    && (pidlMain != NULL)) {
			SendMessageA(hwnd, BFFM_SETSELECTION, FALSE,
				(LPARAM) pidlMain);
			pMalloc->lpVtbl->Free(pMalloc, pidlMain);
		    }
		    psfFolder->lpVtbl->Release(psfFolder);
		}
		pMalloc->lpVtbl->Release(pMalloc);
	    }
	} else {
	    SendMessageA(hwnd, BFFM_SETSELECTION, TRUE, (LPARAM) Tcl_DStringValue(&initDirDStr));
	}
	Tcl_DStringFree(&initDirDStr);
	SendMessageA(hwnd, BFFM_ENABLEOK, 0, (LPARAM) 1);
	break;
    }

    }
    return 0;
}


    enum options {
	MSG_DEFAULT,	MSG_DETAIL,	MSG_ICON,	MSG_MESSAGE,
	MSG_PARENT,	MSG_TITLE,	MSG_TYPE
    };
    ThreadSpecificData *tsdPtr =
	    Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));

    (void) TkWinGetUnicodeEncoding();
    defaultBtn = -1;
    detailObj = NULL;
    icon = MB_ICONINFORMATION;
    messageObj = NULL;
    parent = tkwin;
    titleObj = NULL;
    type = MB_OK;

	 */

	LPCBT_CREATEWND lpcbtcreate = (LPCBT_CREATEWND) lParam;

	if (WC_DIALOG == lpcbtcreate->lpcs->lpszClass) {
	    HWND hwnd = (HWND) wParam;

	    SendMessageA(hwnd, WM_SETICON, ICON_SMALL,
		    (LPARAM) tsdPtr->hSmallIcon);
	    SendMessageA(hwnd, WM_SETICON, ICON_BIG, (LPARAM) tsdPtr->hBigIcon);
	}
    }

    /*
     * Call the next hook proc, if there is one
     */

    sprintf(buf, "0x%p", (HWND) clientData);
    Tcl_SetVar(tsdPtr->debugInterp, "tk_dialog", buf, TCL_GLOBAL_ONLY);
}

/*
 * Factored out a common pattern in use in this file.
 */
static char *
ConvertExternalFilename(
    Tcl_Encoding encoding,
    char *filename,
    Tcl_DString *dsPtr)
{
    char *p;

    Tcl_ExternalToUtfDString(encoding, filename, -1, dsPtr);
    for (p = Tcl_DStringValue(dsPtr); *p != '\0'; p++) {
	/*
	 * Change the pathname to the Tcl "normalized" pathname, where back
	 * slashes are used instead of forward slashes
	 */

	if (*p == '\\') {

GetFontObj(HDC hdc, LOGFONT *plf)
{
    Tcl_DString ds;
    Tcl_Obj *resObj;
    int pt = 0;

    resObj = Tcl_NewListObj(0, NULL);
    Tcl_ExternalToUtfDString(TkWinGetUnicodeEncoding(), (char *) plf->lfFaceName, -1, &ds);
    Tcl_ListObjAppendElement(NULL, resObj,
	    Tcl_NewStringObj(Tcl_DStringValue(&ds), -1));
    Tcl_DStringFree(&ds);
    pt = -MulDiv(plf->lfHeight, 72, GetDeviceCaps(hdc, LOGPIXELSY));
    Tcl_ListObjAppendElement(NULL, resObj, Tcl_NewIntObj(pt));
    if (plf->lfWeight >= 700) {
	Tcl_ListObjAppendElement(NULL, resObj, Tcl_NewStringObj("bold", -1));

	Tk_Font f = Tk_AllocFontFromObj(interp, tkwin, hdPtr->fontObj);

	if (f == NULL) {
	    return TCL_ERROR;
	}
	fontPtr = (TkFont *) f;
	cf.Flags |= CF_INITTOLOGFONTSTRUCT;
    Tcl_UtfToExternalDString(TkWinGetUnicodeEncoding(), fontPtr->fa.family, -1, &ds);
    _tcsncpy(lf.lfFaceName, (TCHAR *)Tcl_DStringValue(&ds), LF_FACESIZE-1);
    Tcl_DStringFree(&ds);
	lf.lfFaceName[LF_FACESIZE-1] = 0;
	lf.lfHeight = -MulDiv(TkFontGetPoints(tkwin, fontPtr->fa.size),
	    GetDeviceCaps(hdc, LOGPIXELSY), 72);
	if (fontPtr->fa.weight == TK_FW_BOLD) {
	    lf.lfWeight = FW_BOLD;