From c6496bf3c66241288028b50e8fddd98442a2ddab Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 14 Dec 2022 17:26:45 +0000 Subject: Allow "tk scaling" in safe interpreters, but not when they try to set the scaling factor --- generic/tkCmds.c | 236 +++---------------------------------------------------- tests/safe.test | 6 +- unix/Makefile.in | 4 +- 3 files changed, 14 insertions(+), 232 deletions(-) diff --git a/generic/tkCmds.c b/generic/tkCmds.c index c5f0a50..b9e07e7 100644 --- a/generic/tkCmds.c +++ b/generic/tkCmds.c @@ -774,7 +774,8 @@ CaretCmd( } Tcl_SetObjResult(interp, Tcl_NewIntObj(value)); } else { - int i, value, x = 0, y = 0, height = -1; + int i; + int value, x = 0, y = 0, height = -1; for (i = 2; i < objc; i += 2) { if ((Tcl_GetIndexFromObj(interp, objv[i], caretStrings, @@ -810,13 +811,6 @@ ScalingCmd( int skip, width, height; double d; - if (Tcl_IsSafe(interp)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "scaling not accessible in a safe interpreter", -1)); - Tcl_SetErrorCode(interp, "TK", "SAFE", "SCALING", NULL); - return TCL_ERROR; - } - skip = TkGetDisplayOf(interp, objc - 1, objv + 1, &tkwin); if (skip < 0) { return TCL_ERROR; @@ -827,6 +821,11 @@ ScalingCmd( d *= WidthOfScreen(screenPtr); d /= WidthMMOfScreen(screenPtr); Tcl_SetObjResult(interp, Tcl_NewDoubleObj(d)); + } else if (Tcl_IsSafe(interp)) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "setting the scaling not accessible in a safe interpreter", -1)); + Tcl_SetErrorCode(interp, "TK", "SAFE", "SCALING", NULL); + return TCL_ERROR; } else if (objc - skip == 2) { if (Tcl_GetDoubleFromObj(interp, objv[1+skip], &d) != TCL_OK) { return TCL_ERROR; @@ -940,11 +939,11 @@ InactiveCmd( return TCL_ERROR; } if (objc - skip == 1) { - long inactive; + Tcl_WideInt inactive; inactive = (Tcl_IsSafe(interp) ? -1 : Tk_GetUserInactiveTime(Tk_Display(tkwin))); - Tcl_SetObjResult(interp, Tcl_NewLongObj(inactive)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(inactive)); } else if (objc - skip == 2) { const char *string; @@ -1824,224 +1823,7 @@ Tk_WinfoObjCmd( return TCL_OK; } -#if 0 -/* - *---------------------------------------------------------------------- - * - * Tk_WmObjCmd -- - * - * This function is invoked to process the "wm" Tcl command. See the user - * documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -int -Tk_WmObjCmd( - ClientData clientData, /* Main window associated with interpreter. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - Tk_Window tkwin; - TkWindow *winPtr; - - static const char *const optionStrings[] = { - "aspect", "client", "command", "deiconify", - "focusmodel", "frame", "geometry", "grid", - "group", "iconbitmap", "iconify", "iconmask", - "iconname", "iconposition", "iconwindow", "maxsize", - "minsize", "overrideredirect", "positionfrom", "protocol", - "resizable", "sizefrom", "state", "title", - "tracing", "transient", "withdraw", NULL - }; - enum options { - TKWM_ASPECT, TKWM_CLIENT, TKWM_COMMAND, TKWM_DEICONIFY, - TKWM_FOCUSMOD, TKWM_FRAME, TKWM_GEOMETRY, TKWM_GRID, - TKWM_GROUP, TKWM_ICONBMP, TKWM_ICONIFY, TKWM_ICONMASK, - TKWM_ICONNAME, TKWM_ICONPOS, TKWM_ICONWIN, TKWM_MAXSIZE, - TKWM_MINSIZE, TKWM_OVERRIDE, TKWM_POSFROM, TKWM_PROTOCOL, - TKWM_RESIZABLE, TKWM_SIZEFROM, TKWM_STATE, TKWM_TITLE, - TKWM_TRACING, TKWM_TRANSIENT, TKWM_WITHDRAW - }; - - tkwin = (Tk_Window) clientData; - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "option window ?arg?"); - return TCL_ERROR; - } - if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0, - &index) != TCL_OK) { - return TCL_ERROR; - } - - if (index == TKWM_TRACING) { - int wmTracing; - TkDisplay *dispPtr = ((TkWindow *) tkwin)->dispPtr; - - if ((objc != 2) && (objc != 3)) { - Tcl_WrongNumArgs(interp, 1, objv, "tracing ?boolean?"); - return TCL_ERROR; - } - if (objc == 2) { - Tcl_SetObjResult(interp, Tcl_NewBooleanObj( - dispPtr->flags & TK_DISPLAY_WM_TRACING)); - return TCL_OK; - } - if (Tcl_GetBooleanFromObj(interp, objv[2], &wmTracing) != TCL_OK) { - return TCL_ERROR; - } - if (wmTracing) { - dispPtr->flags |= TK_DISPLAY_WM_TRACING; - } else { - dispPtr->flags &= ~TK_DISPLAY_WM_TRACING; - } - return TCL_OK; - } - - if (objc < 3) { - Tcl_WrongNumArgs(interp, 2, objv, "window ?arg?"); - return TCL_ERROR; - } - winPtr = (TkWindow *) Tk_NameToWindow(interp, - Tcl_GetString(objv[2]), tkwin); - if (winPtr == NULL) { - return TCL_ERROR; - } - if (!(winPtr->flags & TK_TOP_LEVEL)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "window \"%s\" isn't a top-level window", winPtr->pathName)); - Tcl_SetErrorCode(interp, "TK", "LOOKUP", "TOPLEVEL", winPtr->pathName, - NULL); - return TCL_ERROR; - } - - switch ((enum options) index) { - case TKWM_ASPECT: - TkpWmAspectCmd(interp, tkwin, winPtr, objc, objv); - break; - case TKWM_CLIENT: - TkpWmClientCmd(interp, tkwin, winPtr, objc, objv); - break; - case TKWM_COMMAND: - TkpWmCommandCmd(interp, tkwin, winPtr, objc, objv); - break; - case TKWM_DEICONIFY: - TkpWmDeiconifyCmd(interp, tkwin, winPtr, objc, objv); - break; - case TKWM_FOCUSMOD: - TkpWmFocusmodCmd(interp, tkwin, winPtr, objc, objv); - break; - case TKWM_FRAME: - TkpWmFrameCmd(interp, tkwin, winPtr, objc, objv); - break; - case TKWM_GEOMETRY: - TkpWmGeometryCmd(interp, tkwin, winPtr, objc, objv); - break; - case TKWM_GRID: - TkpWmGridCmd(interp, tkwin, winPtr, objc, objv); - break; - case TKWM_GROUP: - TkpWmGroupCmd(interp, tkwin, winPtr, objc, objv); - break; - case TKWM_ICONBMP: - TkpWmIconbitmapCmd(interp, tkwin, winPtr, objc, objv); - break; - case TKWM_ICONIFY: - TkpWmIconifyCmd(interp, tkwin, winPtr, objc, objv); - break; - case TKWM_ICONMASK: - TkpWmIconmaskCmd(interp, tkwin, winPtr, objc, objv); - break; - case TKWM_ICONNAME: - /* - * Slight Unix variation. - */ - TkpWmIconnameCmd(interp, tkwin, winPtr, objc, objv); - break; - case TKWM_ICONPOS: - /* - * nearly same - 1 line more on Unix. - */ - TkpWmIconpositionCmd(interp, tkwin, winPtr, objc, objv); - break; - case TKWM_ICONWIN: - TkpWmIconwindowCmd(interp, tkwin, winPtr, objc, objv); - break; - case TKWM_MAXSIZE: - /* - * Nearly same, win diffs. - */ - TkpWmMaxsizeCmd(interp, tkwin, winPtr, objc, objv); - break; - case TKWM_MINSIZE: - /* - * Nearly same, win diffs - */ - TkpWmMinsizeCmd(interp, tkwin, winPtr, objc, objv); - break; - case TKWM_OVERRIDE: - /* - * Almost same. - */ - TkpWmOverrideCmd(interp, tkwin, winPtr, objc, objv); - break; - case TKWM_POSFROM: - /* - * Equal across platforms - */ - TkpWmPositionfromCmd(interp, tkwin, winPtr, objc, objv); - break; - case TKWM_PROTOCOL: - /* - * Equal across platforms - */ - TkpWmProtocolCmd(interp, tkwin, winPtr, objc, objv); - break; - case TKWM_RESIZABLE: - /* - * Almost same - */ - TkpWmResizableCmd(interp, tkwin, winPtr, objc, objv); - break; - case TKWM_SIZEFROM: - /* - * Equal across platforms - */ - TkpWmSizefromCmd(interp, tkwin, winPtr, objc, objv); - break; - case TKWM_STATE: - TkpWmStateCmd(interp, tkwin, winPtr, objc, objv); - break; - case TKWM_TITLE: - TkpWmTitleCmd(interp, tkwin, winPtr, objc, objv); - break; - case TKWM_TRANSIENT: - TkpWmTransientCmd(interp, tkwin, winPtr, objc, objv); - break; - case TKWM_WITHDRAW: - TkpWmWithdrawCmd(interp, tkwin, winPtr, objc, objv); - break; - } - - updateGeom: - if (!(wmPtr->flags & (WM_UPDATE_PENDING|WM_NEVER_MAPPED))) { - Tcl_DoWhenIdle(UpdateGeometryInfo, winPtr); - wmPtr->flags |= WM_UPDATE_PENDING; - } - return TCL_OK; -} -#endif - /* *---------------------------------------------------------------------- * diff --git a/tests/safe.test b/tests/safe.test index 31cb1b7..d00f7c1 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -3,7 +3,7 @@ # # Copyright (c) 1994 The Regents of the University of California. # Copyright (c) 1994-1995 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright (c) 1998-1999 Scriptics Corporation. # All rights reserved. package require tcltest 2.2 @@ -141,13 +141,13 @@ test safe-2.4 {Unsafe subcommands not available} -setup { safe::interpCreate a safe::loadTk a set status broken - if {[catch {interp eval a {tk scaling}} msg]} { + if {[catch {interp eval a {tk scaling 1}} msg]} { set status ok } list $status $msg } -cleanup { safe::interpDelete a -} -result {ok {scaling not accessible in a safe interpreter}} +} -result {ok {setting the scaling not accessible in a safe interpreter}} test safe-3.1 {Unsafe commands are available hidden} -setup { catch {safe::interpDelete a} diff --git a/unix/Makefile.in b/unix/Makefile.in index e98070e..77589ba 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -112,7 +112,7 @@ TCL_PLATFORM_DIR = $(TCLDIR)/unix # for this version of Tk: TCL_BIN_DIR = @TCL_BIN_DIR@ -# The linker flags needed to link in the Tcl library (ex: -ltcl8.2) +# The linker flags needed to link in the Tcl library (ex: -ltcl8.6) TCL_LIB_FLAG = @TCL_LIB_FLAG@ # Flag, 1: we're building a shared lib, 0 we're not @@ -190,7 +190,7 @@ KEYSYM_FLAGS = # compile fine with -DTCL_NO_DEPRECATED. To remove its own # set of deprecated code uncomment the second line. NO_DEPRECATED_FLAGS = -#NO_DEPRECATED_FLAGS = -DTK_NO_DEPRECATED +#NO_DEPRECATED_FLAGS = -DTCL_NO_DEPRECATED -DTK_NO_DEPRECATED # Some versions of make, like SGI's, use the following variable to # determine which shell to use for executing commands: -- cgit v0.12