diff options
58 files changed, 1947 insertions, 1484 deletions
@@ -1,3 +1,116 @@ +1999-02-10 <stanton@GASPODE> + + * unix/mkLinks: + * doc/SetVar.3: + * generic/tcl.h: + * generic/tclVar.c: Restored Tcl_ObjGetVar2 and Tcl_ObjSetVar2 + from 8.0. Renamed Tcl_Get/SetObjVar2 to Tcl_GetVar2Ex and + Tcl_SetVar2Ex. + +1999-02-10 <stanton@GASPODE> + + INTEGRATED PATCHES FROM 8.0.5b2: + + * test/winPipe.test: Changed to remove echoArgs.tcl temporary file + when done. + + * tests/cmdAH.test: + * generic/tclFileName.c (TclGetExtension): Changed behavior so the + split happens at the last period in the name instead of the first + period of the last run of periods. So, "foo..o" is split into + "foo." and ".o" now. [Bug: 1126] + + * win/makefile.vc: Added better support for paths with spaces in + the name. Added .lib and support .dlls to the install-binaries + target. Added generate of a pkgIndex.tcl script to the + install-libraries target. + + * win/tclAppInit.c: + * unix/tclAppInit.c: + * mac/tclMacAppInit.c: + * generic/tclTest.c: Changed some EXTERN declarations to extern + since they are not defining exported interfaces. This avoids + generating useless declspec() attributes and makes the windows + makefile simpler. + + * generic/tcl.h: Moved Tcl_AppInit declaration to end and cleared + out TCL_STORAGE_CLASS so it is not declared with a declspec(). + + * tests/interp.test: + * generic/tclInterp.c (DeleteAlias): Changed to use + Tcl_DeleteCommandFromToken so we handle renames properly. This + avoids senseless panic. [Bug: 736] + + * unix/tclUnixChan.c: + * win/tclWinSock.c: + * doc/socket.n: Applied Gordon Chaffee's patch to handle failures + during asynchronous socket connection operations. This adds a new + "-error" fconfgure option to socket channels. [Bug: 893] + + * generic/tclProc.c: + * generic/tclNamesp.c: + * generic/tclInt.h: + * generic/tclCmdIL.c: + * generic/tclBasic.c: + * generic/tclVar.c: Applied patch from Viktor Dukhovni to + rationalize TCL_LEAVE_ERR_MSG behavior when creating variables. + + * generic/tclVar.c: Fixed bug in namespace tail computation. + Fixed bug where upvar could resurrect a namespace variable whose + namespace had been deleted. + + * generic/tclCompile.c (TclCompileExprCmd): Eliminated yet another + bogus optimization in expression compilation. + + * unix/configure.in: Added branch for BSD/OS-4* to shared library + case statement. [Bug: 975] + Fixed to correctly handle IRIX 6.5 n32 library support. [Bug: 1117] + + * win/winDumpExts.c: Patched to be pickier about stripping + @'s. [Bug: 920] + + * library/http2.0/http.tcl: Added catch around eof test in + CopyDone since the user may have already called http::reset. + [Bug: 1108] + + * unix/configure.in: Changed Linux and IRIX to set SHLIB_LIBS to + LIBS so shared libraries are linked with the system + libraries. [Bug: 1018] + + * generic/tclCompile.c (CompileExprWord): Fixed exception stack + overflow bug caused by missing statement. [Bug: 928] + + * generic/tclIOCmd.c: + * generic/tclBasic.c: Objectified the "open" command. [Bug: 1113] + + * generic/tclPosixStr.c (Tcl_ErrnoId, Tcl_ErrnoMsg): When using + egcs, ENOTSUP and EOPNOTSUPP are the same, so now we handle that + case. [Bug: 1137] + + * library/init.tcl: Various small changes requested by Jan Nijtmans. + - If the variable $tcl_library contains the empty string, this + empty string will be put in $auto_path. This is not useful at all, + it only slows down later package processing. + - If the variable tcl_pkgPath is not set, the "unset __dir" + fails. Thich makes init.tcl totally unusable. Better put a "catch" + around it. + - In the function tcl_findLibraries, the "string match" function + only works correctly if $tcl_patchLevel is in one of the forms + "?.?a?", "?.?b?" or "?.?.?". Could a "regexp" be used instead, + then it allows anything to be appended to the patchLevel + string. And it is more efficient. + - The tclPkgSetup function assumes that if $type != "load" then + the type must be "source". This needn't be true. Some users want + to add their own setup types. + [RFE: 1138] [Bug: 978] + + * win/tclWinReg.c: + * doc/registry.n: Added support for HKEY_PERFORMANCE_DATA and + HKEY_DYN_DATA keys. [Bug: 1109] + + * win/tclWinInit.c (TclPlatformInit): Added code to ensure + tcl_pkgPath is set to "" when no registry entry is found. [Bug: 978] + 1999-02-01 <stanton@GASPODE> * generic/tclBasic.c: @@ -1,6 +1,6 @@ Recent user-visible changes to Tcl: -RCS: @(#) $Id: changes,v 1.1.2.17 1999/01/29 00:20:41 stanton Exp $ +RCS: @(#) $Id: changes,v 1.1.2.18 1999/02/10 23:31:10 stanton Exp $ 1. No more [command1] [command2] construct for grouping multiple commands on a single command line. @@ -3696,6 +3696,51 @@ Thanks to Kevin Kenny for this fix. (SS) 1/11/98 (bug fix) On HP, "info sharedlibextension" was returning empty string on static apps. It now always returns ".sl". (RJ) +1/28/99 (configure change) Now support -pipe option on gcc. (RJ) + +2/2/99 (bug fix) Fixed initialization problem on Windows where no +searching for init.tcl would be performed if the registry keys were +missing. (stanton) + +2/2/99 (bug fix) Added support for HKEY_PERFORMANCE_DATA and +HKEY_DYN_DATA keys in the "registry" command. (stanton) + +2/2/99 (bug fix) ENOTSUP and EOPNOTSUPP clashed on some Linux +variants. (stanton) + +2/2/99 (enhancement) The "open" command has been changed to use the +object interfaces. (stanton) + +2/2/99 (bug fix) In some cases Tcl would crash due to an overflow of +the exception stack resulting from a missing byte code in some +expressions. (stanton) + +2/2/99 (bug fix) Changed configure so Linux and IRIX shared libraries +are linked with the system libraries. (stanton) + +2/2/99 (bug fix) Added support for BSDI 4.x (BSD/OS-4*) to the +configure script. (stanton) + +2/2/99 (bug fix) Fixed bug where upvar could resurrect a namespace +variable after the namespace had been deleted. (stanton) + +2/2/99 (bug fix) In some cases when creating variables, the +interpreter result was being modified even if the TCL_LEAVE_ERR_MSG +flag was set. (stanton) + +2/2/99 (bug fix & new feature) Changed the socket drivers to properly +handle failures during an async socket connection. Added a new +fconfigure option "-error" to retrieve the failure message. See the +socket.n manual entry for details. (stanton) + +2/2/99 (bug fix) Deleting a renamed interp alias could result in a +panic. (stanton) + +2/2/99 (feature change/bug fix) Changed the behavior of "file +extension" so that it splits at the last period. Now the extension of +a file like "foo..o" is ".o" instead of "..o" as in previous versions. +*** POTENTIAL INCOMPATIBILITY *** + ======== Changes for 8.0 go above this line ======== ======== Changes for 8.1 go below this line ======== @@ -4061,3 +4106,14 @@ lsort command to better use the object system for improved performance (about 5x speed up). Thanks to Syd Polk for suppling the patch. [RFE: 726] (rjohnson) +2/10/99 (bug fix) Restored the Tcl_ObjSetVar2/Tcl_ObjGetVar2 +interfaces from 8.0 and renamed the Tcl_GetObjVar2/Tcl_SetObjVar2 +interfaces to Tcl_GetVar2Ex and Tcl_SetVar2Ex. This should provide +better compatibility with 8.0. (stanton) +*** POTENTIAL INCOMPATIBILITY with previous alpha/beta releases *** + +2/10/99 (bug fix) Made the eval interfaces compatible with 8.0 by +renaming Tcl_EvalObj to Tcl_EvalObjEx, renaming Tcl_Eval2 to +Tcl_EvalEx and restoring Tcl_EvalObj and Tcl_GlobalEvalObj interfaces +so they match Tcl 8.0. (stanton) +*** POTENTIAL INCOMPATIBILITY with previous alpha/beta releases *** @@ -5,20 +5,20 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: Eval.3,v 1.1.2.3 1998/12/02 01:46:06 stanton Exp $ +'\" RCS: @(#) $Id: Eval.3,v 1.1.2.4 1999/02/10 23:31:11 stanton Exp $ '\" .so man.macros .TH Tcl_Eval 3 8.1 Tcl "Tcl Library Procedures" .BS .SH NAME -Tcl_EvalObj, Tcl_EvalFile, Tcl_EvalObjv, Tcl_Eval, Tcl_Eval2, Tcl_GlobalEval, Tcl_VarEval \- execute Tcl scripts +Tcl_EvalObjEx, Tcl_EvalFile, Tcl_EvalObjv, Tcl_Eval, Tcl_EvalEx, Tcl_GlobalEval, Tcl_GlobalEvalObj, Tcl_VarEval \- execute Tcl scripts .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp .VS int -\fBTcl_EvalObj\fR(\fIinterp, objPtr, flags\fR) +\fBTcl_EvalObjEx\fR(\fIinterp, objPtr, flags\fR) .sp int \fBTcl_EvalFile\fR(\fIinterp, fileName\fR) @@ -30,12 +30,15 @@ int \fBTcl_Eval\fR(\fIinterp, script\fR) .sp int -\fBTcl_Eval2\fR(\fIinterp, script, numBytes, flags\fR) +\fBTcl_EvalEx\fR(\fIinterp, script, numBytes, flags\fR) .sp int \fBTcl_GlobalEval\fR(\fIinterp, script\fR) .sp int +\fBTcl_GlobalEvalObj\fR(\fIinterp, objPtr, flags\fR) +.sp +int \fBTcl_VarEval\fR(\fIinterp, string, string, ... \fB(char *) NULL\fR) .SH ARGUMENTS .AS Tcl_Interp **termPtr; @@ -71,7 +74,7 @@ String forming part of a Tcl script. .PP The procedures described here are invoked to execute Tcl scripts in various forms. -\fBTcl_EvalObj\fR is the core procedure and is used by many of the others. +\fBTcl_EvalObjEx\fR is the core procedure and is used by many of the others. It executes the commands in the script stored in \fIobjPtr\fR until either an error occurs or the end of the script is reached. If this is the first time \fIobjPtr\fR has been executed, @@ -80,7 +83,7 @@ which are then executed. The bytecodes are saved in \fIobjPtr\fR so that the compilation step can be skipped if the object is evaluated again in the future. .PP -The return value from \fBTcl_EvalObj\fR (and all the other procedures +The return value from \fBTcl_EvalObjEx\fR (and all the other procedures described here) is a Tcl completion code with one of the values \fBTCL_OK\fR, \fBTCL_ERROR\fR, \fBTCL_RETURN\fR, \fBTCL_BREAK\fR, or \fBTCL_CONTINUE\fR. @@ -89,7 +92,7 @@ result; it can be retrieved using \fBTcl_GetObjResult\fR. .PP \fBTcl_EvalFile\fR reads the file given by \fIfileName\fR and evaluates its contents as a Tcl script. It returns the same information as -\fBTcl_EvalObj\fR. +\fBTcl_EvalObjEx\fR. If the file couldn't be read then a Tcl error is returned to describe why the file couldn't be read. .PP @@ -97,33 +100,32 @@ why the file couldn't be read. script. The \fIobjc\fR and \fIobjv\fR arguments contain the values of the words for the Tcl command, one word in each object in \fIobjv\fR. \fBTcl_EvalObjv\fR evaluates the command and returns -a completion code and result just like \fBTcl_EvalObj\fR. +a completion code and result just like \fBTcl_EvalObjEx\fR. .PP -\fBTcl_Eval\fR is similar to \fBTcl_EvalObj\fR except that +\fBTcl_Eval\fR is similar to \fBTcl_EvalObjEx\fR except that the script to be executed is supplied as a string instead of an object and no compilation occurs. The string is parsed and executed directly (using \fBTcl_EvalObjv\fR) instead of compiling it and executing the bytecodes. In situations where it is known that the script will never be executed again, \fBTcl_Eval\fR may be -faster than \fBTcl_EvalObj\fR. \fBTcl_Eval\fR returns a completion -code and result just like \fBTcl_EvalObj\fR. Note: for backward +faster than \fBTcl_EvalObjEx\fR. \fBTcl_Eval\fR returns a completion +code and result just like \fBTcl_EvalObjEx\fR. Note: for backward compatibility with versions before Tcl 8.0, \fBTcl_Eval\fR copies the object result in \fIinterp\fR to \fIinterp->result\fR where it can be accessed directly. This makes \fBTcl_Eval\fR somewhat -slower than \fBTcl_Eval2\fR, which doesn't do the copy. +slower than \fBTcl_EvalEx\fR, which doesn't do the copy. .PP -\fBTcl_Eval2\fR is an extended version of \fBTcl_Eval\fR that takes +\fBTcl_EvalEx\fR is an extended version of \fBTcl_Eval\fR that takes additional arguments \fInumBytes\fR and \fIflags\fR. For the -efficiency reason given above, \fBTcl_Eval2\fR is generally preferred +efficiency reason given above, \fBTcl_EvalEx\fR is generally preferred over \fBTcl_Eval\fR. .PP -\fBTcl_GlobalEval\fR is an older procedure that is now deprecated. -It is similar to \fBTcl_Eval\fR except that the script is evaluated in -the global namespace and its variable context consists of global -variables only (it ignores any Tcl procedures that are active). -Like \fBTcl_Eval\fR, it leaves a null-terminated -string version of the result in \fIinterp->result\fR where it can -be accessed directly. +\fBTcl_GlobalEval\fR and \fBTcl_GlobalEvalObj\fR are older procedures +that are now deprecated. They are similar to \fBTcl_EvalEx\fR and +\fBTcl_EvalObjEx\fR except that the script is evaluated in the global +namespace and its variable context consists of global variables only +(it ignores any Tcl procedures that are active). These functions are +equivalent to using the \fBTCL_EVAL_GLOBAL\fR flag (see below). .PP \fBTcl_VarEval\fR takes any number of string arguments of any length, concatenates them into a single string, @@ -135,13 +137,13 @@ of arguments. \fBTcl_VarEval\fR is now deprecated. .SH "FLAG BITS" Any ORed combination of the following values may be used for the -\fIflags\fR argument to procedures such as \fBTcl_EvalObj\fR: +\fIflags\fR argument to procedures such as \fBTcl_EvalObjEx\fR: .TP 23 \fBTCL_EVAL_DIRECT\fR -This flag is only used by \fBTcl_EvalObj\fR; it is ignored by +This flag is only used by \fBTcl_EvalObjEx\fR; it is ignored by other procedures. If this flag bit is set, the script is not compiled to bytecodes; instead it is executed directly -as is done by \fBTcl_Eval2\fR. The +as is done by \fBTcl_EvalEx\fR. The \fBTCL_EVAL_DIRECT\fR flag is useful in situations where the contents of an object are going to change immediately, so the bytecodes won't be reused in a future execution. In this case, @@ -159,7 +161,7 @@ During the processing of a Tcl command it is legal to make nested calls to evaluate other commands (this is how procedures and some control structures are implemented). If a code other than \fBTCL_OK\fR is returned -from a nested \fBTcl_EvalObj\fR invocation, +from a nested \fBTcl_EvalObjEx\fR invocation, then the caller should normally return immediately, passing that same return code back to its caller, and so on until the top-level application is reached. @@ -167,17 +169,17 @@ A few commands, like \fBfor\fR, will check for certain return codes, like \fBTCL_BREAK\fR and \fBTCL_CONTINUE\fR, and process them specially without returning. .PP -\fBTcl_EvalObj\fR keeps track of how many nested \fBTcl_EvalObj\fR +\fBTcl_EvalObjEx\fR keeps track of how many nested \fBTcl_EvalObjEx\fR invocations are in progress for \fIinterp\fR. If a code of \fBTCL_RETURN\fR, \fBTCL_BREAK\fR, or \fBTCL_CONTINUE\fR is -about to be returned from the topmost \fBTcl_EvalObj\fR +about to be returned from the topmost \fBTcl_EvalObjEx\fR invocation for \fIinterp\fR, it converts the return code to \fBTCL_ERROR\fR and sets \fIinterp\fR's result to an error message indicating that the \fBreturn\fR, \fBbreak\fR, or \fBcontinue\fR command was invoked in an inappropriate place. This means that top-level applications should never see a return code -from \fBTcl_EvalObj\fR other then \fBTCL_OK\fR or \fBTCL_ERROR\fR. +from \fBTcl_EvalObjEx\fR other then \fBTCL_OK\fR or \fBTCL_ERROR\fR. .VE .SH KEYWORDS diff --git a/doc/SetVar.3 b/doc/SetVar.3 index 462c866..4049a0f 100644 --- a/doc/SetVar.3 +++ b/doc/SetVar.3 @@ -5,20 +5,20 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: SetVar.3,v 1.1.2.2 1998/09/24 23:58:26 stanton Exp $ +'\" RCS: @(#) $Id: SetVar.3,v 1.1.2.3 1999/02/10 23:31:11 stanton Exp $ '\" .so man.macros .TH Tcl_SetVar 3 8.1 Tcl "Tcl Library Procedures" .BS .SH NAME -Tcl_SetObjVar2, Tcl_SetVar, Tcl_SetVar2, Tcl_GetObjVar2, Tcl_GetVar, Tcl_GetVar2, Tcl_UnsetVar, Tcl_UnsetVar2 \- manipulate Tcl variables +Tcl_SetVar2Ex, Tcl_SetVar, Tcl_SetVar2, Tcl_ObjSetVar2, Tcl_GetVar2Ex, Tcl_GetVar, Tcl_GetVar2, Tcl_ObjGetVar2, Tcl_UnsetVar, Tcl_UnsetVar2 \- manipulate Tcl variables .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp .VS 8.1 Tcl_Obj * -\fBTcl_SetObjVar2\fR(\fIinterp, name1, name2, newValuePtr, flags\fR) +\fBTcl_SetVar2Ex\fR(\fIinterp, name1, name2, newValuePtr, flags\fR) .VE .sp char * @@ -27,9 +27,12 @@ char * char * \fBTcl_SetVar2\fR(\fIinterp, name1, name2, newValue, flags\fR) .sp +Tcl_Obj * +\fBTcl_ObjSetVar2\fR(\fIinterp, part1Ptr, part2Ptr, newValuePtr, flags\fR) +.sp .VS 8.1 Tcl_Obj * -\fBTcl_GetObjVar2\fR(\fIinterp, name1, name2, flags\fR) +\fBTcl_GetVar2Ex\fR(\fIinterp, name1, name2, flags\fR) .VE .sp char * @@ -38,6 +41,9 @@ char * char * \fBTcl_GetVar2\fR(\fIinterp, name1, name2, flags\fR) .sp +Tcl_Obj * +\fBTcl_ObjGetVar2\fR(\fIinterp, part1Ptr, part2Ptr, flags\fR) +.sp int \fBTcl_UnsetVar\fR(\fIinterp, varName, flags\fR) .sp @@ -75,6 +81,14 @@ to it while looking up the name. .AP char *newValue in New value for variable, specified as a NULL-terminated string. A copy of this value is stored in the variable. +.AP Tcl_Obj *part1Ptr in +Points to a Tcl object containing the variable's name. +The name may include a series of \fB::\fR namespace qualifiers +to specify a variable in a particular namespace. +May refer to a scalar variable or an element of an array variable. +.AP Tcl_Obj *part2Ptr in +If non-NULL, points to an object containing the name of an element +within an array and \fIpart1Ptr\fR must refer to an array variable. .BE .SH DESCRIPTION @@ -83,16 +97,18 @@ These procedures are used to create, modify, read, and delete Tcl variables from C code. .PP .VS 8.1 -\fBTcl_SetObjVar2\fR, \fBTcl_SetVar\fR, and \fBTcl_SetVar2\fR +\fBTcl_SetVar2Ex\fR, \fBTcl_SetVar\fR, \fBTcl_SetVar2\fR, and +\fBTcl_ObjSetVar2\fR will create a new variable or modify an existing one. These procedures set the given variable to the value given by \fInewValuePtr\fR or \fInewValue\fR and return a pointer to the variable's new value, which is stored in Tcl's variable structure. -\fBTcl_SetObjVar2\fR takes the new value as a Tcl_Obj and returns +\fBTcl_SetVar2Ex\fR and \fBTcl_ObjSetVar2\fR take the new value as a +Tcl_Obj and return a pointer to a Tcl_Obj. \fBTcl_SetVar\fR and \fBTcl_SetVar2\fR take the new value as a string and return a string; they are -usually less efficient than \fBTcl_SetObjVar2\fR. Note that the +usually less efficient than \fBTcl_ObjSetVar2\fR. Note that the return value may be different than the \fInewValuePtr\fR or .VE \fInewValue\fR argument, due to modifications made by write traces. @@ -102,15 +118,18 @@ NULL is returned and an error message is left in \fIinterp\fR's result if the \fBTCL_LEAVE_ERR_MSG\fR \fIflag\fR bit is set. .PP .VS 8.1 -\fBTcl_GetObjVar2\fR, \fBTcl_GetVar\fR, and \fBTcl_GetVar2\fR +\fBTcl_GetVar2Ex\fR, \fBTcl_GetVar\fR, \fBTcl_GetVar2\fR, and +\fBTcl_ObjGetVar2\fR return the current value of a variable. The arguments to these procedures are treated in the same way -as the arguments as the procedures above. +as the arguments to the procedures described above. Under normal circumstances, the return value is a pointer -to the variable's value. For \fBTcl_GetObjVar2\fR the value is +to the variable's value. For \fBTcl_GetVar2Ex\fR and +\fBTcl_ObjGetVar2\fR the value is returned as a pointer to a Tcl_Obj. For \fBTcl_GetVar\fR and \fBTcl_GetVar2\fR the value is returned as a string; this is -usually less efficient, so \fBTcl_GetObjVar2\fR is preferred. +usually less efficient, so \fBTcl_GetVar2Ex\fR or \fBTcl_ObjGetVar2\fR +are preferred. .VE If an error occurs while reading the variable (e.g. the variable doesn't exist or an array element is specified for a scalar diff --git a/doc/format.n b/doc/format.n index f7d40f2..d964c8a 100644 --- a/doc/format.n +++ b/doc/format.n @@ -5,7 +5,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: format.n,v 1.1.2.1 1998/09/24 23:58:31 stanton Exp $ +'\" RCS: @(#) $Id: format.n,v 1.1.2.2 1999/02/10 23:31:11 stanton Exp $ '\" .so man.macros .TH format n "" Tcl "Tcl Built-In Commands" @@ -154,9 +154,11 @@ Convert integer to unsigned octal string. \fBx\fR or \fBX\fR Convert integer to unsigned hexadecimal string, using digits ``0123456789abcdef'' for \fBx\fR and ``0123456789ABCDEF'' for \fBX\fR). +.VS .TP 10 \fBc\fR -Convert integer to the 8-bit character it represents. +Convert integer to the Unicode character it represents. +.VE .TP 10 \fBs\fR No conversion; just insert string. diff --git a/doc/registry.n b/doc/registry.n index 268270e..5ef85d5 100644 --- a/doc/registry.n +++ b/doc/registry.n @@ -4,7 +4,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: registry.n,v 1.1.2.1 1998/09/24 23:58:35 stanton Exp $ +'\" RCS: @(#) $Id: registry.n,v 1.1.2.2 1999/02/10 23:31:12 stanton Exp $ '\" .so man.macros .TH registry n 8.0 Tcl "Tcl Built-In Commands" @@ -39,8 +39,11 @@ one of the following forms: \fIHostname\fR specifies the name of any valid Windows host that exports its registry. The \fIrootname\fR component must be one of \fBHKEY_LOCAL_MACHINE\fR, \fBHKEY_USERS\fR, -\fBHKEY_CLASSES_ROOT\fR, \fBHKEY_CURRENT_USER\fR, or -\fBHKEY_CURRENT_CONFIG\fR. The \fIkeypath\fR can be one or more +.VS +\fBHKEY_CLASSES_ROOT\fR, \fBHKEY_CURRENT_USER\fR, +\fBHKEY_CURRENT_CONFIG\fR, \fBHKEY_PERFORMANCE_DATA\fR, or +\fBHKEY_DYN_DATA\fR. The \fIkeypath\fR can be one or more +.VE registry key names separated by backslash (\fB\e\fR) characters. .PP \fIOption\fR indicates what to do with the registry key name. Any diff --git a/doc/socket.n b/doc/socket.n index ac5d501..cb0b943 100644 --- a/doc/socket.n +++ b/doc/socket.n @@ -1,12 +1,13 @@ '\" '\" Copyright (c) 1996 Sun Microsystems, Inc. +'\" Copyright (c) 1998-1999 by Scriptics Corporation. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: socket.n,v 1.1.2.1 1998/09/24 23:58:36 stanton Exp $ +'\" RCS: @(#) $Id: socket.n,v 1.1.2.2 1999/02/10 23:31:12 stanton Exp $ .so man.macros -.TH socket n 7.5 Tcl "Tcl Built-In Commands" +.TH socket n 8.0 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME @@ -103,6 +104,14 @@ will be accepted. .SH CONFIGURATION OPTIONS The \fBfconfigure\fR command can be used to query several readonly configuration options for socket channels: +.VS 8.0.5 +.TP +\fB\-error\fR +This option gets the current error status of the given socket. This +is useful when you need to determine if an asynchronous connect +operation succeeded. If there was an error, the error message is +returned. If there was no error, an empty string is returned. +.VE 8.0.5 .TP \fB\-sockname\fR This option returns a list of three elements, the address, the host name diff --git a/generic/tcl.h b/generic/tcl.h index 4b6864b..d8dad65 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tcl.h,v 1.1.2.11 1999/02/01 21:29:48 stanton Exp $ + * RCS: @(#) $Id: tcl.h,v 1.1.2.12 1999/02/10 23:31:12 stanton Exp $ */ #ifndef _TCL @@ -515,6 +515,7 @@ typedef struct Tcl_Obj { EXTERN void Tcl_IncrRefCount _ANSI_ARGS_((Tcl_Obj *objPtr)); EXTERN void Tcl_DecrRefCount _ANSI_ARGS_((Tcl_Obj *objPtr)); EXTERN int Tcl_IsShared _ANSI_ARGS_((Tcl_Obj *objPtr)); +EXTERN void TclFreeObj _ANSI_ARGS_((Tcl_Obj *objPtr)); #ifdef TCL_MEM_DEBUG # define Tcl_IncrRefCount(objPtr) \ @@ -1289,7 +1290,6 @@ EXTERN void Tcl_AppendToObj _ANSI_ARGS_((Tcl_Obj *objPtr, char *bytes, int length)); EXTERN void Tcl_AppendStringsToObj _ANSI_ARGS_( TCL_VARARGS(Tcl_Obj *,interp)); -EXTERN int Tcl_AppInit _ANSI_ARGS_((Tcl_Interp *interp)); EXTERN void Tcl_AlertNotifier _ANSI_ARGS_((ClientData clientData)); EXTERN Tcl_AsyncHandler Tcl_AsyncCreate _ANSI_ARGS_((Tcl_AsyncProc *proc, ClientData clientData)); @@ -1364,9 +1364,8 @@ EXTERN Tcl_Command Tcl_CreateObjCommand _ANSI_ARGS_(( Tcl_CmdDeleteProc *deleteProc)); EXTERN Tcl_Interp * Tcl_CreateSlave _ANSI_ARGS_((Tcl_Interp *interp, char *slaveName, int isSafe)); -EXTERN void Tcl_CreateThreadExitHandler - _ANSI_ARGS_((Tcl_ExitProc *proc, - ClientData clientData)); +EXTERN void Tcl_CreateThreadExitHandler _ANSI_ARGS_(( + Tcl_ExitProc *proc, ClientData clientData)); EXTERN Tcl_TimerToken Tcl_CreateTimerHandler _ANSI_ARGS_((int milliseconds, Tcl_TimerProc *proc, ClientData clientData)); EXTERN Tcl_Trace Tcl_CreateTrace _ANSI_ARGS_((Tcl_Interp *interp, @@ -1422,14 +1421,14 @@ EXTERN void Tcl_DeleteHashEntry _ANSI_ARGS_(( EXTERN void Tcl_DeleteHashTable _ANSI_ARGS_(( Tcl_HashTable *tablePtr)); EXTERN void Tcl_DeleteInterp _ANSI_ARGS_((Tcl_Interp *interp)); -EXTERN void Tcl_DeleteThreadExitHandler - _ANSI_ARGS_((Tcl_ExitProc *proc, - ClientData clientData)); +EXTERN void Tcl_DeleteThreadExitHandler _ANSI_ARGS_(( + Tcl_ExitProc *proc, ClientData clientData)); EXTERN void Tcl_DeleteTimerHandler _ANSI_ARGS_(( Tcl_TimerToken token)); EXTERN void Tcl_DeleteTrace _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Trace trace)); -EXTERN void Tcl_DetachPids _ANSI_ARGS_((int numPids, Tcl_Pid *pidPtr)); +EXTERN void Tcl_DetachPids _ANSI_ARGS_((int numPids, + Tcl_Pid *pidPtr)); EXTERN void Tcl_DiscardResult _ANSI_ARGS_(( Tcl_SavedResult *statePtr)); EXTERN void Tcl_DontCallWhenDeleted _ANSI_ARGS_(( @@ -1507,7 +1506,6 @@ EXTERN Tcl_HashEntry * Tcl_FirstHashEntry _ANSI_ARGS_(( Tcl_HashSearch *searchPtr)); EXTERN int Tcl_Flush _ANSI_ARGS_((Tcl_Channel chan)); EXTERN void Tcl_FreeEncoding _ANSI_ARGS_((Tcl_Encoding encoding)); -EXTERN void TclFreeObj _ANSI_ARGS_((Tcl_Obj *objPtr)); EXTERN void Tcl_FreeResult _ANSI_ARGS_((Tcl_Interp *interp)); EXTERN int Tcl_GetAlias _ANSI_ARGS_((Tcl_Interp *interp, char *slaveCmd, Tcl_Interp **targetInterpPtr, @@ -1575,8 +1573,6 @@ EXTERN int Tcl_GetLongFromObj _ANSI_ARGS_((Tcl_Interp *interp, EXTERN Tcl_Interp * Tcl_GetMaster _ANSI_ARGS_((Tcl_Interp *interp)); EXTERN CONST char * Tcl_GetNameOfExecutable _ANSI_ARGS_((void)); EXTERN Tcl_Obj * Tcl_GetObjResult _ANSI_ARGS_((Tcl_Interp *interp)); -EXTERN Tcl_Obj * Tcl_GetObjVar2 _ANSI_ARGS_((Tcl_Interp *interp, - char *part1, char *part2, int flags)); EXTERN Tcl_ObjType * Tcl_GetObjType _ANSI_ARGS_((char *typeName)); EXTERN int Tcl_GetOpenFile _ANSI_ARGS_((Tcl_Interp *interp, char *string, int write, int checkUsage, @@ -1600,6 +1596,8 @@ EXTERN char * Tcl_GetVar _ANSI_ARGS_((Tcl_Interp *interp, char *varName, int flags)); EXTERN char * Tcl_GetVar2 _ANSI_ARGS_((Tcl_Interp *interp, char *part1, char *part2, int flags)); +EXTERN Tcl_Obj * Tcl_GetVar2Ex _ANSI_ARGS_((Tcl_Interp *interp, + char *part1, char *part2, int flags)); EXTERN int Tcl_GlobalEval _ANSI_ARGS_((Tcl_Interp *interp, char *command)); EXTERN char * Tcl_HashStats _ANSI_ARGS_((Tcl_HashTable *tablePtr)); @@ -1663,6 +1661,12 @@ EXTERN void Tcl_NotifyChannel _ANSI_ARGS_((Tcl_Channel channel, int mask)); EXTERN int Tcl_NumUtfChars _ANSI_ARGS_((CONST char *src, int len)); +EXTERN Tcl_Obj * Tcl_ObjGetVar2 _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, + int flags)); +EXTERN Tcl_Obj * Tcl_ObjSetVar2 _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, + Tcl_Obj *newValuePtr, int flags)); EXTERN Tcl_Channel Tcl_OpenCommandChannel _ANSI_ARGS_(( Tcl_Interp *interp, int argc, char **argv, int flags)); @@ -1760,9 +1764,6 @@ EXTERN void Tcl_SetObjLength _ANSI_ARGS_((Tcl_Obj *objPtr, int length)); EXTERN void Tcl_SetObjResult _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *resultObjPtr)); -EXTERN Tcl_Obj * Tcl_SetObjVar2 _ANSI_ARGS_((Tcl_Interp *interp, - char *part1, char *part2, Tcl_Obj *newValuePtr, - int flags)); EXTERN void Tcl_SetPanicProc _ANSI_ARGS_((void (*proc) _ANSI_ARGS_(TCL_VARARGS(char *, format)))); EXTERN int Tcl_SetRecursionLimit _ANSI_ARGS_((Tcl_Interp *interp, @@ -1782,6 +1783,9 @@ EXTERN char * Tcl_SetVar _ANSI_ARGS_((Tcl_Interp *interp, EXTERN char * Tcl_SetVar2 _ANSI_ARGS_((Tcl_Interp *interp, char *part1, char *part2, char *newValue, int flags)); +EXTERN Tcl_Obj * Tcl_SetVar2Ex _ANSI_ARGS_((Tcl_Interp *interp, + char *part1, char *part2, Tcl_Obj *newValuePtr, + int flags)); EXTERN char * Tcl_SignalId _ANSI_ARGS_((int sig)); EXTERN char * Tcl_SignalMsg _ANSI_ARGS_((int sig)); EXTERN void Tcl_Sleep _ANSI_ARGS_((int ms)); @@ -1890,6 +1894,17 @@ EXTERN int Tcl_WriteObj _ANSI_ARGS_((Tcl_Channel chan, EXTERN void Tcl_WrongNumArgs _ANSI_ARGS_((Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], char *message)); +#undef TCL_STORAGE_CLASS +#define TCL_STORAGE_CLASS + +/* + * Convenience declaration of Tcl_AppInit for backwards compatibility. + * This function is not *implemented* by the tcl library, so the storage + * class is neither DLLEXPORT nor DLLIMPORT + */ + +EXTERN int Tcl_AppInit _ANSI_ARGS_((Tcl_Interp *interp)); + #endif /* RESOURCE_INCLUDED */ #undef TCL_STORAGE_CLASS diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 92902da8..3ea4d08 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -7,12 +7,12 @@ * * Copyright (c) 1987-1994 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. - * Copyright (c) 1998 by Scriptics Corporation. + * Copyright (c) 1998-1999 by Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclBasic.c,v 1.1.2.7 1999/02/01 21:29:49 stanton Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.1.2.8 1999/02/10 23:31:12 stanton Exp $ */ #include "tclInt.h" @@ -1417,7 +1417,7 @@ Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc) Command *cmdPtr, *refCmdPtr; Tcl_HashEntry *hPtr; char *tail; - int new, result; + int new; ImportedCmdData *dataPtr; if (iPtr->flags & DELETED) { @@ -1436,10 +1436,9 @@ Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc) */ if (strstr(cmdName, "::") != NULL) { - result = TclGetNamespaceForQualName(interp, cmdName, - (Namespace *) NULL, CREATE_NS_IF_UNKNOWN, &nsPtr, - &dummy1, &dummy2, &tail); - if ((result != TCL_OK) || (nsPtr == NULL) || (tail == NULL)) { + TclGetNamespaceForQualName(interp, cmdName, (Namespace *) NULL, + CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail); + if ((nsPtr == NULL) || (tail == NULL)) { return (Tcl_Command) NULL; } } else { @@ -1564,7 +1563,7 @@ Tcl_CreateObjCommand(interp, cmdName, proc, clientData, deleteProc) Command *cmdPtr, *refCmdPtr; Tcl_HashEntry *hPtr; char *tail; - int new, result; + int new; ImportedCmdData *dataPtr; if (iPtr->flags & DELETED) { @@ -1583,10 +1582,9 @@ Tcl_CreateObjCommand(interp, cmdName, proc, clientData, deleteProc) */ if (strstr(cmdName, "::") != NULL) { - result = TclGetNamespaceForQualName(interp, cmdName, - (Namespace *) NULL, CREATE_NS_IF_UNKNOWN, &nsPtr, - &dummy1, &dummy2, &tail); - if ((result != TCL_OK) || (nsPtr == NULL) || (tail == NULL)) { + TclGetNamespaceForQualName(interp, cmdName, (Namespace *) NULL, + CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail); + if ((nsPtr == NULL) || (tail == NULL)) { return (Tcl_Command) NULL; } } else { @@ -1914,12 +1912,9 @@ TclRenameCommand(interp, oldName, newName) * Tcl_CreateCommand would. */ - result = TclGetNamespaceForQualName(interp, newName, (Namespace *) NULL, - (CREATE_NS_IF_UNKNOWN | TCL_LEAVE_ERR_MSG), - &newNsPtr, &dummy1, &dummy2, &newTail); - if (result != TCL_OK) { - return result; - } + TclGetNamespaceForQualName(interp, newName, (Namespace *) NULL, + CREATE_NS_IF_UNKNOWN, &newNsPtr, &dummy1, &dummy2, &newTail); + if ((newNsPtr == NULL) || (newTail == NULL)) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't rename to \"", newName, "\": bad command name", @@ -3960,7 +3955,7 @@ Tcl_AddObjErrorInfo(interp, message, length) iPtr->flags |= ERR_IN_PROGRESS; if (iPtr->result[0] == 0) { - (void) Tcl_SetObjVar2(interp, "errorInfo", NULL, iPtr->objResultPtr, + (void) Tcl_SetVar2Ex(interp, "errorInfo", NULL, iPtr->objResultPtr, TCL_GLOBAL_ONLY); } else { /* use the string result */ Tcl_SetVar2(interp, "errorInfo", (char *) NULL, interp->result, @@ -3985,7 +3980,7 @@ Tcl_AddObjErrorInfo(interp, message, length) if (length != 0) { messagePtr = Tcl_NewStringObj(message, length); Tcl_IncrRefCount(messagePtr); - Tcl_SetObjVar2(interp, "errorInfo", NULL, messagePtr, + Tcl_SetVar2Ex(interp, "errorInfo", NULL, messagePtr, (TCL_GLOBAL_ONLY | TCL_APPEND_VALUE)); Tcl_DecrRefCount(messagePtr); /* free msg object appended above */ } diff --git a/generic/tclBinary.c b/generic/tclBinary.c index e8cd6a6..fc14b92 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclBinary.c,v 1.1.2.2 1998/09/24 23:58:41 stanton Exp $ + * RCS: @(#) $Id: tclBinary.c,v 1.1.2.3 1999/02/10 23:31:13 stanton Exp $ */ #include <math.h> @@ -964,10 +964,8 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) } } valuePtr = Tcl_NewByteArrayObj(src, size); - resultPtr = Tcl_SetObjVar2(interp, - Tcl_GetString(objv[arg]), - NULL, valuePtr, - TCL_LEAVE_ERR_MSG); + resultPtr = Tcl_ObjSetVar2(interp, objv[arg], + NULL, valuePtr, TCL_LEAVE_ERR_MSG); arg++; if (resultPtr == NULL) { Tcl_DecrRefCount(valuePtr); /* unneeded */ @@ -1019,10 +1017,8 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) } } - resultPtr = Tcl_SetObjVar2(interp, - Tcl_GetString(objv[arg]), - NULL, valuePtr, - TCL_LEAVE_ERR_MSG); + resultPtr = Tcl_ObjSetVar2(interp, objv[arg], + NULL, valuePtr, TCL_LEAVE_ERR_MSG); arg++; if (resultPtr == NULL) { Tcl_DecrRefCount(valuePtr); /* unneeded */ @@ -1076,10 +1072,8 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) } } - resultPtr = Tcl_SetObjVar2(interp, - Tcl_GetString(objv[arg]), - NULL, valuePtr, - TCL_LEAVE_ERR_MSG); + resultPtr = Tcl_ObjSetVar2(interp, objv[arg], + NULL, valuePtr, TCL_LEAVE_ERR_MSG); arg++; if (resultPtr == NULL) { Tcl_DecrRefCount(valuePtr); /* unneeded */ @@ -1140,10 +1134,8 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) offset += count*size; } - resultPtr = Tcl_SetObjVar2(interp, - Tcl_GetString(objv[arg]), - NULL, valuePtr, - TCL_LEAVE_ERR_MSG); + resultPtr = Tcl_ObjSetVar2(interp, objv[arg], + NULL, valuePtr, TCL_LEAVE_ERR_MSG); arg++; if (resultPtr == NULL) { Tcl_DecrRefCount(valuePtr); /* unneeded */ diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 982b5d7..447c01d 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCmdAH.c,v 1.1.2.8 1999/02/01 21:29:49 stanton Exp $ + * RCS: @(#) $Id: tclCmdAH.c,v 1.1.2.9 1999/02/10 23:31:13 stanton Exp $ */ #include "tclInt.h" @@ -261,8 +261,7 @@ Tcl_CatchObjCmd(dummy, interp, objc, objv) result = Tcl_EvalObjEx(interp, objv[1], 0); if (objc == 3) { - if (Tcl_SetObjVar2(interp, - Tcl_GetString(varNamePtr), NULL, + if (Tcl_ObjSetVar2(interp, varNamePtr, NULL, Tcl_GetObjResult(interp), 0) == NULL) { Tcl_ResetResult(interp); Tcl_AppendToObj(Tcl_GetObjResult(interp), @@ -572,7 +571,7 @@ Tcl_ErrorObjCmd(dummy, interp, objc, objv) } if (objc == 4) { - Tcl_SetObjVar2(interp, "errorCode", NULL, objv[3], TCL_GLOBAL_ONLY); + Tcl_SetVar2Ex(interp, "errorCode", NULL, objv[3], TCL_GLOBAL_ONLY); iPtr->flags |= ERROR_CODE_SET; } @@ -1767,8 +1766,7 @@ Tcl_ForeachObjCmd(dummy, interp, objc, objv) valuePtr = Tcl_NewObj(); /* empty string */ isEmptyObj = 1; } - varValuePtr = Tcl_SetObjVar2(interp, - Tcl_GetString(varvList[i][v]), + varValuePtr = Tcl_ObjSetVar2(interp, varvList[i][v], NULL, valuePtr, 0); if (varValuePtr == NULL) { if (isEmptyObj) { diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index abf261f..56d48cb 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -9,12 +9,12 @@ * Copyright (c) 1987-1993 The Regents of the University of California. * Copyright (c) 1993-1997 Lucent Technologies. * Copyright (c) 1994-1997 Sun Microsystems, Inc. - * Copyright (c) 1998 by Scriptics Corporation. + * Copyright (c) 1998-1999 by Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCmdIL.c,v 1.1.2.6 1999/02/01 21:29:50 stanton Exp $ + * RCS: @(#) $Id: tclCmdIL.c,v 1.1.2.7 1999/02/10 23:31:14 stanton Exp $ */ #include "tclInt.h" @@ -663,7 +663,6 @@ InfoCommandsCmd(dummy, interp, objc, objv) Tcl_Obj *listPtr, *elemObjPtr; int specificNsInPattern = 0; /* Init. to avoid compiler warning. */ Tcl_Command cmd; - int result; /* * Get the pattern and find the "effective namespace" in which to @@ -685,13 +684,11 @@ InfoCommandsCmd(dummy, interp, objc, objv) Namespace *dummy1NsPtr, *dummy2NsPtr; - pattern = Tcl_GetString(objv[2]); - result = TclGetNamespaceForQualName(interp, pattern, - (Namespace *) NULL, /*flags*/ TCL_LEAVE_ERR_MSG, - &nsPtr, &dummy1NsPtr, &dummy2NsPtr, &simplePattern); - if (result != TCL_OK) { - return TCL_ERROR; - } + + pattern = Tcl_GetString(objv[2]); + TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL, + /*flags*/ 0, &nsPtr, &dummy1NsPtr, &dummy2NsPtr, &simplePattern); + if (nsPtr != NULL) { /* we successfully found the pattern's ns */ specificNsInPattern = (strcmp(simplePattern, pattern) != 0); } @@ -851,8 +848,7 @@ InfoDefaultCmd(dummy, interp, objc, objv) if (TclIsVarArgument(localPtr) && (strcmp(argName, localPtr->name) == 0)) { if (localPtr->defValuePtr != NULL) { - valueObjPtr = Tcl_SetObjVar2(interp, - Tcl_GetString(objv[4]), NULL, + valueObjPtr = Tcl_ObjSetVar2(interp, objv[4], NULL, localPtr->defValuePtr, 0); if (valueObjPtr == NULL) { defStoreError: @@ -865,8 +861,8 @@ InfoDefaultCmd(dummy, interp, objc, objv) Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); } else { Tcl_Obj *nullObjPtr = Tcl_NewObj(); - valueObjPtr = Tcl_SetObjVar2(interp, - Tcl_GetString(objv[4]), NULL, nullObjPtr, 0); + valueObjPtr = Tcl_ObjSetVar2(interp, objv[4], NULL, + nullObjPtr, 0); if (valueObjPtr == NULL) { Tcl_DecrRefCount(nullObjPtr); /* free unneeded obj */ goto defStoreError; @@ -1659,7 +1655,6 @@ InfoVarsCmd(dummy, interp, objc, objv) Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); Tcl_Obj *listPtr, *elemObjPtr; int specificNsInPattern = 0; /* Init. to avoid compiler warning. */ - int result; /* * Get the pattern and find the "effective namespace" in which to @@ -1683,12 +1678,10 @@ InfoVarsCmd(dummy, interp, objc, objv) Namespace *dummy1NsPtr, *dummy2NsPtr; pattern = Tcl_GetString(objv[2]); - result = TclGetNamespaceForQualName(interp, pattern, - (Namespace *) NULL, /*flags*/ TCL_LEAVE_ERR_MSG, - &nsPtr, &dummy1NsPtr, &dummy2NsPtr, &simplePattern); - if (result != TCL_OK) { - return TCL_ERROR; - } + TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL, + /*flags*/ 0, &nsPtr, &dummy1NsPtr, &dummy2NsPtr, + &simplePattern); + if (nsPtr != NULL) { /* we successfully found the pattern's ns */ specificNsInPattern = (strcmp(simplePattern, pattern) != 0); } diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 4e76c3f..337f697 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCompCmds.c,v 1.1.2.7 1998/12/01 23:33:39 stanton Exp $ + * RCS: @(#) $Id: tclCompCmds.c,v 1.1.2.8 1999/02/10 23:31:14 stanton Exp $ */ #include "tclInt.h" @@ -171,7 +171,7 @@ TclCompileCatchCmd(interp, parsePtr, envPtr) envPtr->exceptDepth++; envPtr->maxExceptDepth = TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth); - range = TclCreateExceptRange(CATCH_EXCEPTION, envPtr); + range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); TclEmitInstInt4(INST_BEGIN_CATCH4, range, envPtr); startOffset = (envPtr->codeNext - envPtr->codeStart); @@ -409,8 +409,8 @@ TclCompileForCmd(interp, parsePtr, envPtr) envPtr->exceptDepth++; envPtr->maxExceptDepth = TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth); - bodyRange = TclCreateExceptRange(LOOP_EXCEPTION, envPtr); - nextRange = TclCreateExceptRange(LOOP_EXCEPTION, envPtr); + bodyRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); + nextRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); /* * Inline compile the initial command. @@ -762,7 +762,7 @@ TclCompileForeachCmd(interp, parsePtr, envPtr) * Evaluate then store each value list in the associated temporary. */ - range = TclCreateExceptRange(LOOP_EXCEPTION, envPtr); + range = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); loopIndex = 0; for (i = 0, tokenPtr = parsePtr->tokenPtr; @@ -1863,7 +1863,7 @@ TclCompileWhileCmd(interp, parsePtr, envPtr) envPtr->exceptDepth++; envPtr->maxExceptDepth = TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth); - range = TclCreateExceptRange(LOOP_EXCEPTION, envPtr); + range = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); envPtr->exceptArrayPtr[range].continueOffset = (envPtr->codeNext - envPtr->codeStart); diff --git a/generic/tclCompile.c b/generic/tclCompile.c index cdf6e9e..e18faa7 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCompile.c,v 1.1.2.8 1998/12/12 01:36:54 lfb Exp $ + * RCS: @(#) $Id: tclCompile.c,v 1.1.2.9 1999/02/10 23:31:14 stanton Exp $ */ #include "tclInt.h" @@ -1367,7 +1367,7 @@ TclCompileExprWords(interp, tokenPtr, numWords, envPtr) envPtr->exceptDepth++; envPtr->maxExceptDepth = TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth); - range = TclCreateExceptRange(CATCH_EXCEPTION, envPtr); + range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); TclEmitInstInt4(INST_BEGIN_CATCH4, range, envPtr); Tcl_DStringInit(&exprBuffer); @@ -2516,13 +2516,13 @@ TclFixupForwardJump(envPtr, jumpFixupPtr, jumpDist, distThreshold) rangePtr->codeOffset += 3; switch (rangePtr->type) { - case LOOP_EXCEPTION: + case LOOP_EXCEPTION_RANGE: rangePtr->breakOffset += 3; if (rangePtr->continueOffset != -1) { rangePtr->continueOffset += 3; } break; - case CATCH_EXCEPTION: + case CATCH_EXCEPTION_RANGE: rangePtr->catchOffset += 3; break; default: @@ -3028,15 +3028,16 @@ TclPrintByteCodeObj(interp, objPtr) ExceptionRange *rangePtr = &(codePtr->exceptArrayPtr[i]); fprintf(stdout, " %d: level %d, %s, pc %d-%d, ", i, rangePtr->nestingLevel, - ((rangePtr->type == LOOP_EXCEPTION)? "loop" : "catch"), + ((rangePtr->type == LOOP_EXCEPTION_RANGE) + ? "loop" : "catch"), rangePtr->codeOffset, (rangePtr->codeOffset + rangePtr->numCodeBytes - 1)); switch (rangePtr->type) { - case LOOP_EXCEPTION: + case LOOP_EXCEPTION_RANGE: fprintf(stdout, "continue %d, break %d\n", rangePtr->continueOffset, rangePtr->breakOffset); break; - case CATCH_EXCEPTION: + case CATCH_EXCEPTION_RANGE: fprintf(stdout, "catch %d\n", rangePtr->catchOffset); break; default: diff --git a/generic/tclCompile.h b/generic/tclCompile.h index b7da7c4..6f5d099 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -6,7 +6,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCompile.h,v 1.1.2.3 1998/09/30 20:46:24 stanton Exp $ + * RCS: @(#) $Id: tclCompile.h,v 1.1.2.4 1999/02/10 23:31:15 stanton Exp $ */ #ifndef _TCLCOMPILATION @@ -82,10 +82,10 @@ extern int tclTraceExec; */ typedef enum { - LOOP_EXCEPTION, /* Exception's range is part of a loop. + LOOP_EXCEPTION_RANGE, /* Exception's range is part of a loop. * Break and continue "exceptions" cause * jumps to appropriate PC offsets. */ - CATCH_EXCEPTION /* Exception's range is controlled by a + CATCH_EXCEPTION_RANGE /* Exception's range is controlled by a * catch command. Errors in the range cause * a jump to a catch PC offset. */ } ExceptionRangeType; @@ -98,13 +98,13 @@ typedef struct ExceptionRange { int codeOffset; /* Offset of the first instruction byte of * the code range. */ int numCodeBytes; /* Number of bytes in the code range. */ - int breakOffset; /* If LOOP_EXCEPTION, the target PC offset - * for a break command in the range. */ - int continueOffset; /* If LOOP_EXCEPTION and not -1, the target - * PC offset for a continue command in the - * code range. Otherwise, ignore this range + int breakOffset; /* If LOOP_EXCEPTION_RANGE, the target PC + * offset for a break command in the range. */ + int continueOffset; /* If LOOP_EXCEPTION_RANGE and not -1, the + * target PC offset for a continue command in + * the code range. Otherwise, ignore this range * when processing a continue command. */ - int catchOffset; /* If a CATCH_EXCEPTION, the target PC + int catchOffset; /* If a CATCH_EXCEPTION_RANGE, the target PC * offset for any "exception" in range. */ } ExceptionRange; diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 2ee7669..b0f3ea4 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclExecute.c,v 1.1.2.8 1999/02/01 21:29:51 stanton Exp $ + * RCS: @(#) $Id: tclExecute.c,v 1.1.2.9 1999/02/10 23:31:16 stanton Exp $ */ #include "tclInt.h" @@ -906,7 +906,7 @@ TclExecuteByteCode(interp, codePtr) } newPcOffset = 0; switch (rangePtr->type) { - case LOOP_EXCEPTION: + case LOOP_EXCEPTION_RANGE: if (result == TCL_BREAK) { newPcOffset = rangePtr->breakOffset; } else if (rangePtr->continueOffset == -1) { @@ -922,7 +922,7 @@ TclExecuteByteCode(interp, codePtr) StringForResultCode(result), rangePtr->codeOffset, newPcOffset)); break; - case CATCH_EXCEPTION: + case CATCH_EXCEPTION_RANGE: TRACE(("%u => ... after \"%.20s\", %s...\n", objc, cmdNameBuf, StringForResultCode(result))); @@ -998,7 +998,7 @@ TclExecuteByteCode(interp, codePtr) goto abnormalReturn; /* no catch exists to check */ } switch (rangePtr->type) { - case LOOP_EXCEPTION: + case LOOP_EXCEPTION_RANGE: if (result == TCL_BREAK) { newPcOffset = rangePtr->breakOffset; } else if (rangePtr->continueOffset == -1) { @@ -1014,7 +1014,7 @@ TclExecuteByteCode(interp, codePtr) O2S(objPtr), StringForResultCode(result), rangePtr->codeOffset, newPcOffset), valuePtr); break; - case CATCH_EXCEPTION: + case CATCH_EXCEPTION_RANGE: TRACE_WITH_OBJ(("\"%.30s\" => %s ", O2S(objPtr), StringForResultCode(result)), valuePtr); @@ -1097,8 +1097,7 @@ TclExecuteByteCode(interp, codePtr) case INST_LOAD_SCALAR_STK: objPtr = POP_OBJECT(); /* scalar name */ DECACHE_STACK_INFO(); - valuePtr = Tcl_GetObjVar2(interp, - Tcl_GetString(objPtr), NULL, TCL_LEAVE_ERR_MSG); + valuePtr = Tcl_ObjGetVar2(interp, objPtr, NULL, TCL_LEAVE_ERR_MSG); CACHE_STACK_INFO(); if (valuePtr == NULL) { TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(objPtr)), @@ -1149,8 +1148,7 @@ TclExecuteByteCode(interp, codePtr) objPtr = POP_OBJECT(); /* array name */ DECACHE_STACK_INFO(); - valuePtr = Tcl_GetObjVar2(interp, - Tcl_GetString(objPtr), Tcl_GetString(elemPtr), + valuePtr = Tcl_ObjGetVar2(interp, objPtr, elemPtr, TCL_LEAVE_ERR_MSG); CACHE_STACK_INFO(); if (valuePtr == NULL) { @@ -1173,8 +1171,7 @@ TclExecuteByteCode(interp, codePtr) case INST_LOAD_STK: objPtr = POP_OBJECT(); /* variable name */ DECACHE_STACK_INFO(); - valuePtr = Tcl_GetObjVar2(interp, Tcl_GetString(objPtr), NULL, - TCL_LEAVE_ERR_MSG); + valuePtr = Tcl_ObjGetVar2(interp, objPtr, NULL, TCL_LEAVE_ERR_MSG); CACHE_STACK_INFO(); if (valuePtr == NULL) { TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", @@ -1220,8 +1217,8 @@ TclExecuteByteCode(interp, codePtr) valuePtr = POP_OBJECT(); objPtr = POP_OBJECT(); /* scalar name */ DECACHE_STACK_INFO(); - value2Ptr = Tcl_SetObjVar2(interp, Tcl_GetString(objPtr), NULL, - valuePtr, TCL_LEAVE_ERR_MSG); + value2Ptr = Tcl_ObjSetVar2(interp, objPtr, NULL, valuePtr, + TCL_LEAVE_ERR_MSG); CACHE_STACK_INFO(); if (value2Ptr == NULL) { TRACE_WITH_OBJ(("\"%.30s\" <- \"%.30s\" => ERROR: ", @@ -1283,9 +1280,8 @@ TclExecuteByteCode(interp, codePtr) elemPtr = POP_OBJECT(); objPtr = POP_OBJECT(); /* array name */ DECACHE_STACK_INFO(); - value2Ptr = Tcl_SetObjVar2(interp, - Tcl_GetString(objPtr), Tcl_GetString(elemPtr), - valuePtr, TCL_LEAVE_ERR_MSG); + value2Ptr = Tcl_ObjSetVar2(interp, objPtr, elemPtr, valuePtr, + TCL_LEAVE_ERR_MSG); CACHE_STACK_INFO(); if (value2Ptr == NULL) { TRACE_WITH_OBJ(("\"%.30s(%.30s)\" <- \"%.30s\" => ERROR: ", @@ -1311,8 +1307,8 @@ TclExecuteByteCode(interp, codePtr) valuePtr = POP_OBJECT(); objPtr = POP_OBJECT(); /* variable name */ DECACHE_STACK_INFO(); - value2Ptr = Tcl_SetObjVar2(interp, Tcl_GetString(objPtr), NULL, - valuePtr, TCL_LEAVE_ERR_MSG); + value2Ptr = Tcl_ObjSetVar2(interp, objPtr, NULL, valuePtr, + TCL_LEAVE_ERR_MSG); CACHE_STACK_INFO(); if (value2Ptr == NULL) { TRACE_WITH_OBJ(("\"%.30s\" <- \"%.30s\" => ERROR: ", @@ -2564,12 +2560,12 @@ TclExecuteByteCode(interp, codePtr) goto abnormalReturn; /* no catch exists to check */ } switch (rangePtr->type) { - case LOOP_EXCEPTION: + case LOOP_EXCEPTION_RANGE: result = TCL_OK; TRACE(("=> range at %d, new pc %d\n", rangePtr->codeOffset, rangePtr->breakOffset)); break; - case CATCH_EXCEPTION: + case CATCH_EXCEPTION_RANGE: result = TCL_BREAK; TRACE(("=> ...\n")); goto processCatch; /* it will use rangePtr */ @@ -2596,7 +2592,7 @@ TclExecuteByteCode(interp, codePtr) goto abnormalReturn; } switch (rangePtr->type) { - case LOOP_EXCEPTION: + case LOOP_EXCEPTION_RANGE: if (rangePtr->continueOffset == -1) { TRACE(("=> loop w/o continue, checking for catch\n")); goto checkForCatch; @@ -2606,7 +2602,7 @@ TclExecuteByteCode(interp, codePtr) rangePtr->codeOffset, rangePtr->continueOffset)); } break; - case CATCH_EXCEPTION: + case CATCH_EXCEPTION_RANGE: result = TCL_CONTINUE; TRACE(("=> ...\n")); goto processCatch; /* it will use rangePtr */ @@ -3317,7 +3313,7 @@ GetExceptRangeForPc(pc, catchOnly, codePtr) int end = (start + rangePtr->numCodeBytes); if ((start <= pcOffset) && (pcOffset < end)) { if ((!catchOnly) - || (rangePtr->type == CATCH_EXCEPTION)) { + || (rangePtr->type == CATCH_EXCEPTION_RANGE)) { return rangePtr; } } diff --git a/generic/tclFileName.c b/generic/tclFileName.c index b14577a..7da53a9 100644 --- a/generic/tclFileName.c +++ b/generic/tclFileName.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclFileName.c,v 1.1.2.7 1998/12/12 01:36:58 lfb Exp $ + * RCS: @(#) $Id: tclFileName.c,v 1.1.2.8 1999/02/10 23:31:16 stanton Exp $ */ #include "tclInt.h" @@ -1088,15 +1088,12 @@ TclGetExtension(name) } /* - * Back up to the first period in a series of contiguous dots. - * This is needed so foo..o will be split on the first dot. + * In earlier versions, we used to back up to the first period in a series + * so that "foo..o" would be split into "foo" and "..o". This is a + * confusing and usually incorrect behavior, so now we split at the last + * period in the name. */ - if (p != NULL) { - while ((p > name) && *(p-1) == '.') { - p--; - } - } return p; } diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index 92ca4cf..334b129 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIOCmd.c,v 1.1.2.2 1998/09/24 23:58:52 stanton Exp $ + * RCS: @(#) $Id: tclIOCmd.c,v 1.1.2.3 1999/02/10 23:31:17 stanton Exp $ */ #include "tclInt.h" @@ -252,8 +252,8 @@ Tcl_GetsObjCmd(dummy, interp, objc, objv) lineLen = -1; } if (objc == 3) { - if (Tcl_SetObjVar2(interp, Tcl_GetString(objv[2]), - NULL, linePtr, TCL_LEAVE_ERR_MSG ) == NULL) { + if (Tcl_ObjSetVar2(interp, objv[2], NULL, linePtr, + TCL_LEAVE_ERR_MSG) == NULL) { Tcl_DecrRefCount(linePtr); return TCL_ERROR; } diff --git a/generic/tclInt.h b/generic/tclInt.h index c8c41b6..de3f6cb 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -6,12 +6,12 @@ * Copyright (c) 1987-1993 The Regents of the University of California. * Copyright (c) 1993-1997 Lucent Technologies. * Copyright (c) 1994-1998 Sun Microsystems, Inc. - * Copyright (c) 1998 by Scriptics Corporation. + * Copyright (c) 1998-1999 by Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclInt.h,v 1.1.2.10 1998/12/24 00:13:59 rjohnson Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.1.2.11 1999/02/10 23:31:17 stanton Exp $ */ #ifndef _TCLINT @@ -22,7 +22,7 @@ * included here, so that system-dependent personalizations for the * include files only have to be made in once place. This results * in a few extra includes, but greater modularity. The order of - * the three groups of #includes is important. For example, stdio.h + * the three groups of #includes is important. For example, stdio.h * is needed by tcl.h, and the _ANSI_ARGS_ declaration in tcl.h is * needed by stdlib.h in some configurations. */ @@ -97,18 +97,18 @@ typedef int (Tcl_ResolveVarProc) _ANSI_ARGS_(( int flags, Tcl_Var *rPtr)); typedef int (Tcl_ResolveCmdProc) _ANSI_ARGS_((Tcl_Interp* interp, - char* name, Tcl_Namespace *context, int flags, - Tcl_Command *rPtr)); + char* name, Tcl_Namespace *context, int flags, + Tcl_Command *rPtr)); typedef struct Tcl_ResolverInfo { Tcl_ResolveCmdProc *cmdResProc; /* Procedure handling command name - * resolution. */ + * resolution. */ Tcl_ResolveVarProc *varResProc; /* Procedure handling variable name - * resolution for variables that - * can only be handled at runtime. */ + * resolution for variables that + * can only be handled at runtime. */ Tcl_ResolveCompiledVarProc *compiledVarResProc; - /* Procedure handling variable name - * resolution at compile time. */ + /* Procedure handling variable name + * resolution at compile time. */ } Tcl_ResolverInfo; /* @@ -140,7 +140,7 @@ typedef struct Namespace { * this one. NULL if this is the global * namespace. */ Tcl_HashTable childTable; /* Contains any child namespaces. Indexed - * by strings; values have type + * by strings; values have type * (Namespace *). */ long nsId; /* Unique id for the namespace. */ Tcl_Interp *interp; /* The interpreter containing this @@ -157,8 +157,8 @@ typedef struct Namespace { * objects. The namespace can't be freed * until refCount becomes zero. */ Tcl_HashTable cmdTable; /* Contains all the commands currently - * registered in the namespace. Indexed by - * strings; values have type (Command *). + * registered in the namespace. Indexed by + * strings; values have type (Command *). * Commands imported by Tcl_Import have * Command structures that point (via an * ImportedCmdRef structure) to the @@ -166,7 +166,7 @@ typedef struct Namespace { * namespace's command table. */ Tcl_HashTable varTable; /* Contains all the (global) variables * currently in this namespace. Indexed - * by strings; values have type (Var *). */ + * by strings; values have type (Var *). */ char **exportArrayPtr; /* Points to an array of string patterns * specifying which commands are exported. * A pattern may include "string match" @@ -229,8 +229,8 @@ typedef struct Namespace { * namespace's storage will be freed. */ -#define NS_DYING 0x01 -#define NS_DEAD 0x02 +#define NS_DYING 0x01 +#define NS_DEAD 0x02 /* * Flag passed to TclGetNamespaceForQualName to have it create all namespace @@ -271,7 +271,7 @@ typedef struct VarTrace { /* * When a variable trace is active (i.e. its associated procedure is * executing), one of the following structures is linked into a list - * associated with the variable's interpreter. The information in + * associated with the variable's interpreter. The information in * the structure is needed in order for Tcl to behave reasonably * if traces are deleted while traces are active. */ @@ -303,9 +303,9 @@ typedef struct ArraySearch { Tcl_HashSearch search; /* Info kept by the hash module about * progress through the array. */ Tcl_HashEntry *nextEntry; /* Non-null means this is the next element - * to be enumerated (it's leftover from + * to be enumerated (it's leftover from * the Tcl_FirstHashEntry call or from - * an "array anymore" command). NULL + * an "array anymore" command). NULL * means must call Tcl_NextHashEntry * to get value to return. */ struct ArraySearch *nextPtr;/* Next in list of all active searches @@ -383,7 +383,7 @@ typedef struct Var { * than a scalar variable or link. The * "tablePtr" field points to the array's * hashtable for its elements. - * VAR_LINK - 1 means this Var structure contains a + * VAR_LINK - 1 means this Var structure contains a * pointer to another Var structure that * either has the real value or is itself * another VAR_LINK pointer. Variables like @@ -434,7 +434,7 @@ typedef struct Var { #define VAR_SCALAR 0x1 #define VAR_ARRAY 0x2 #define VAR_LINK 0x4 -#define VAR_UNDEFINED 0x8 +#define VAR_UNDEFINED 0x8 #define VAR_IN_HASHTABLE 0x10 #define VAR_TRACE_ACTIVE 0x20 #define VAR_ARRAY_ELEMENT 0x40 @@ -606,7 +606,7 @@ typedef struct Proc { } Proc; /* - * The structure below defines a command trace. This is used to allow Tcl + * The structure below defines a command trace. This is used to allow Tcl * clients to find out whenever a command is about to be executed. */ @@ -628,7 +628,7 @@ typedef struct Trace { typedef struct AssocData { Tcl_InterpDeleteProc *proc; /* Proc to call when deleting. */ ClientData clientData; /* Value to pass to proc. */ -} AssocData; +} AssocData; /* * The structure below defines a call frame. A call frame defines a naming @@ -707,7 +707,7 @@ void TclHandleRelease _ANSI_ARGS_((TclHandle handle)); /* *---------------------------------------------------------------- - * Data structures related to history. These are used primarily + * Data structures related to history. These are used primarily * in tclHistory.c *---------------------------------------------------------------- */ @@ -879,7 +879,7 @@ typedef struct ExecEnv { */ typedef struct LiteralEntry { - struct LiteralEntry *nextPtr; /* Points to next entry in this + struct LiteralEntry *nextPtr; /* Points to next entry in this * hash bucket or NULL if end of * chain. */ Tcl_Obj *objPtr; /* Points to Tcl object that @@ -940,7 +940,7 @@ typedef struct ByteCodeStats { double currentLitBytes; /* Current literal bytes. */ double currentExceptBytes; /* Current exception table bytes. */ double currentAuxBytes; /* Current auxiliary information bytes. */ - double currentCmdMapBytes; /* Current src<->code map bytes. */ + double currentCmdMapBytes; /* Current src<->code map bytes. */ long numLiteralsCreated; /* Total literal objects ever compiled. */ double totalLitStringBytes; /* Total string bytes in all literals. */ @@ -965,7 +965,7 @@ typedef struct ByteCodeStats { typedef struct ImportRef { struct Command *importedCmdPtr; - /* Points to the imported command created in + /* Points to the imported command created in * an importing namespace; this command * redirects its invocations to the "real" * command. */ @@ -984,7 +984,7 @@ typedef struct ImportRef { typedef struct ImportedCmdData { struct Command *realCmdPtr; /* "Real" command that this imported command - * refers to. */ + * refers to. */ struct Command *selfPtr; /* Pointer to this imported command. Needed * only when deleting it in order to remove * it from the real command's linked list of @@ -1016,9 +1016,9 @@ typedef struct Command { * structure can be freed when refCount * becomes zero. */ int cmdEpoch; /* Incremented to invalidate any references - * that point to this command when it is + * that point to this command when it is * renamed, deleted, hidden, or exposed. */ - CompileProc *compileProc; /* Procedure called to compile command. NULL + CompileProc *compileProc; /* Procedure called to compile command. NULL * if no compile proc exists for command. */ Tcl_ObjCmdProc *objProc; /* Object-based command procedure. */ ClientData objClientData; /* Arbitrary value passed to object proc. */ @@ -1087,7 +1087,7 @@ typedef struct Interp { /* * Note: the first three fields must match exactly the fields in - * a Tcl_Interp struct (see tcl.h). If you change one, be sure to + * a Tcl_Interp struct (see tcl.h). If you change one, be sure to * change the other. * * The interpreter's result is held in both the string and the @@ -1101,16 +1101,16 @@ typedef struct Interp { * and Tcl_GetStringResult. See the SetResult man page for details. */ - char *result; /* If the last command returned a string + char *result; /* If the last command returned a string * result, this points to it. Should not be * accessed directly; see comment above. */ - Tcl_FreeProc *freeProc; /* Zero means a string result is statically - * allocated. TCL_DYNAMIC means string - * result was allocated with ckalloc and - * should be freed with ckfree. Other values - * give address of procedure to invoke to - * free the string result. Tcl_Eval must - * free it before executing next command. */ + Tcl_FreeProc *freeProc; /* Zero means a string result is statically + * allocated. TCL_DYNAMIC means string + * result was allocated with ckalloc and + * should be freed with ckfree. Other values + * give address of procedure to invoke to + * free the string result. Tcl_Eval must + * free it before executing next command. */ int errorLine; /* When TCL_ERROR is returned, this gives * the line number in the command where the * error occurred (1 means first line). */ @@ -1121,7 +1121,7 @@ typedef struct Interp { TclHandle handle; /* Handle used to keep track of when this * interp is deleted. */ - Namespace *globalNsPtr; /* The interpreter's global namespace. */ + Namespace *globalNsPtr; /* The interpreter's global namespace. */ Tcl_HashTable *hiddenCmdTablePtr; /* Hash table used by tclBasic.c to keep * track of hidden commands on a per-interp @@ -1130,7 +1130,7 @@ typedef struct Interp { * track of master/slave interps on * a per-interp basis. */ Tcl_HashTable mathFuncTable;/* Contains all the math functions currently - * defined for the interpreter. Indexed by + * defined for the interpreter. Indexed by * strings (function names); values have * type (MathFunc *). */ @@ -1143,7 +1143,7 @@ typedef struct Interp { int numLevels; /* Keeps track of how many nested calls to * Tcl_Eval are in progress for this - * interpreter. It's used to delay deletion + * interpreter. It's used to delay deletion * of the table until all Tcl_Eval * invocations are completed. */ int maxNestingDepth; /* If numLevels exceeds this value then Tcl @@ -1169,11 +1169,11 @@ typedef struct Interp { /* * Information used by Tcl_AppendResult to keep track of partial - * results. See Tcl_AppendResult code for details. + * results. See Tcl_AppendResult code for details. */ char *appendResult; /* Storage space for results generated - * by Tcl_AppendResult. Malloc-ed. NULL + * by Tcl_AppendResult. Malloc-ed. NULL * means not yet allocated. */ int appendAvl; /* Total amount of space available at * partialResult. */ @@ -1181,7 +1181,7 @@ typedef struct Interp { * stored at partialResult. */ /* - * A cache of compiled regular expressions. See Tcl_RegExpCompile + * A cache of compiled regular expressions. See Tcl_RegExpCompile * in tclUtil.c for details. THIS CACHE IS OBSOLETE and is only * retained for backward compatibility with Tcl_RegExpCompile. * New code should use the object interface so the Tcl_Obj caches @@ -1190,7 +1190,7 @@ typedef struct Interp { #define NUM_REGEXPS 5 char *patterns[NUM_REGEXPS];/* Strings corresponding to compiled - * regular expression patterns. NULL + * regular expression patterns. NULL * means that this slot isn't used. * Malloc-ed. */ int patLengths[NUM_REGEXPS];/* Number of non-null characters in @@ -1225,7 +1225,7 @@ typedef struct Interp { * values. */ int termOffset; /* Offset of character just after last one * compiled or executed by Tcl_EvalObj. */ - LiteralTable literalTable; /* Contains LiteralEntry's describing all + LiteralTable literalTable; /* Contains LiteralEntry's describing all * Tcl objects holding literals of scripts * compiled by the interpreter. Indexed by * the string representations of literals. @@ -1256,10 +1256,10 @@ typedef struct Interp { long randSeed; /* Seed used for rand() function. */ Trace *tracePtr; /* List of traces for this interpreter. */ Tcl_HashTable *assocData; /* Hash table for associating data with - * this interpreter. Cleaned up when - * this interpreter is deleted. */ + * this interpreter. Cleaned up when + * this interpreter is deleted. */ struct ExecEnv *execEnvPtr; /* Execution environment for Tcl bytecode - * execution. Contains a pointer to the + * execution. Contains a pointer to the * Tcl evaluation stack. */ Tcl_Obj *emptyObjPtr; /* Points to an object holding an empty * string. Returned by Tcl_ObjSetVar2 when @@ -1277,7 +1277,7 @@ typedef struct Interp { #ifdef TCL_COMPILE_STATS ByteCodeStats stats; /* Holds compilation and execution * statistics for this interpreter. */ -#endif /* TCL_COMPILE_STATS */ +#endif /* TCL_COMPILE_STATS */ } Interp; /* @@ -1286,7 +1286,7 @@ typedef struct Interp { * TCL_BRACKET_TERM 1 means that the current script is terminated by * a close bracket rather than the end of the string. * TCL_ALLOW_EXCEPTIONS 1 means it's OK for the script to terminate with - * a code other than TCL_OK or TCL_ERROR; 0 means + * a code other than TCL_OK or TCL_ERROR; 0 means * codes other than these should be turned into errors. */ @@ -1309,7 +1309,7 @@ typedef struct Interp { * "error message log" command). * ERROR_CODE_SET: Non-zero means that Tcl_SetErrorCode has been * called to record information for the current - * error. Zero means Tcl_Eval must clear the + * error. Zero means Tcl_Eval must clear the * errorCode variable if an error is returned. * EXPR_INITIALIZED: Non-zero means initialization specific to * expressions has been carried out. @@ -1318,14 +1318,14 @@ typedef struct Interp { * sequence of instructions. This is set 1, for * example, when command traces are requested. * RAND_SEED_INITIALIZED: Non-zero means that the randSeed value of the - * interp has not be initialized. This is set 1 + * interp has not be initialized. This is set 1 * when we first use the rand() or srand() functions. - * SAFE_INTERP: Non zero means that the current interp is a - * safe interp (ie it has only the safe commands - * installed, less priviledge than a regular interp). + * SAFE_INTERP: Non zero means that the current interp is a + * safe interp (ie it has only the safe commands + * installed, less priviledge than a regular interp). * USE_EVAL_DIRECT: Non-zero means don't use the compiler or byte-code * interpreter; instead, have Tcl_EvalObj call - * Tcl_EvalDirect. Used primarily for testing the + * Tcl_EvalDirect. Used primarily for testing the * new parser. */ @@ -1336,7 +1336,7 @@ typedef struct Interp { #define EXPR_INITIALIZED 0x10 #define DONT_COMPILE_CMDS_INLINE 0x20 #define RAND_SEED_INITIALIZED 0x40 -#define SAFE_INTERP 0x80 +#define SAFE_INTERP 0x80 #define USE_EVAL_DIRECT 0x100 /* @@ -1372,7 +1372,7 @@ typedef struct ParseValue { /* *---------------------------------------------------------------- * The following data structures and declarations are for the new - * Tcl parser. This stuff should all move to tcl.h eventually. + * Tcl parser. This stuff should all move to tcl.h eventually. *---------------------------------------------------------------- */ @@ -1416,7 +1416,7 @@ typedef struct Tcl_Token { * text that is part of a word. * NumComponents is always 0. * TCL_TOKEN_BS - The token describes a backslash sequence - * that must be collapsed. NumComponents + * that must be collapsed. NumComponents * is always 0. * TCL_TOKEN_COMMAND - The token describes a command whose result * must be substituted into the word. The @@ -1453,7 +1453,7 @@ typedef struct Tcl_Token { * primitive operand is described by a * TCL_TOKEN_SUB_EXPR token followed by a * TCL_TOKEN_TEXT token. A binary subexpression - * is described by a TCL_TOKEN_SUB_EXPR token + * is described by a TCL_TOKEN_SUB_EXPR token * followed by the TCL_TOKEN_OPERATOR token * for the operator, then TCL_TOKEN_SUB_EXPR * tokens for the left then the right operands. @@ -1510,7 +1510,7 @@ typedef struct Tcl_Parse { /* * The fields below are intended only for the private use of the - * parser. They should not be used by procedures that invoke + * parser. They should not be used by procedures that invoke * Tcl_ParseCommand. */ @@ -1650,7 +1650,7 @@ typedef int (TclSetFileAttrProc) _ANSI_ARGS_((Tcl_Interp *interp, int objIndex, CONST char *fileName, Tcl_Obj *attrObjPtr)); typedef struct TclFileAttrProcs { - TclGetFileAttrProc *getProc; /* The procedure for getting attrs. */ + TclGetFileAttrProc *getProc; /* The procedure for getting attrs. */ TclSetFileAttrProc *setProc; /* The procedure for setting attrs. */ } TclFileAttrProcs; @@ -1689,11 +1689,11 @@ typedef int (*TclObjCmdProcType) _ANSI_ARGS_((ClientData clientData, extern Tcl_Time tclBlockTime; extern int tclBlockTimeSet; extern char * tclExecutableName; -extern Tcl_ChannelType tclFileChannelType; +extern Tcl_ChannelType tclFileChannelType; extern char * tclMemDumpFileName; extern TclPlatformType tclPlatform; extern char * tclpFileAttrStrings[]; -extern CONST TclFileAttrProcs tclpFileAttrProcs[]; +extern CONST TclFileAttrProcs tclpFileAttrProcs[]; /* * Variables denoting the Tcl object types defined in the core. @@ -1715,8 +1715,8 @@ extern Tcl_ObjType tclStringType; extern Tcl_Obj * tclFreeObjList; #ifdef TCL_COMPILE_STATS -extern long tclObjsAlloced; -extern long tclObjsFreed; +extern long tclObjsAlloced; +extern long tclObjsFreed; #endif /* TCL_COMPILE_STATS */ /* @@ -1741,7 +1741,7 @@ EXTERN int TclAccessDeleteProc _ANSI_ARGS_((TclAccessProc_ *proc)); EXTERN int TclAccessInsertProc _ANSI_ARGS_((TclAccessProc_ *proc)); EXTERN void TclAllocateFreeObjects _ANSI_ARGS_((void)); EXTERN int TclCleanupChildren _ANSI_ARGS_((Tcl_Interp *interp, - int numPids, Tcl_Pid *pidPtr, + int numPids, Tcl_Pid *pidPtr, Tcl_Channel errorChan)); EXTERN void TclCleanupCommand _ANSI_ARGS_((Command *cmdPtr)); EXTERN int TclCopyAndCollapse _ANSI_ARGS_((int count, @@ -1761,7 +1761,7 @@ EXTERN int TclCreateProc _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *argsPtr, Tcl_Obj *bodyPtr, Proc **procPtrPtr)); EXTERN void TclDeleteCompiledLocalVars _ANSI_ARGS_(( - Interp *iPtr, CallFrame *framePtr)); + Interp *iPtr, CallFrame *framePtr)); EXTERN void TclDeleteVars _ANSI_ARGS_((Interp *iPtr, Tcl_HashTable *tablePtr)); EXTERN int TclDoGlob _ANSI_ARGS_((Tcl_Interp *interp, @@ -1776,7 +1776,7 @@ EXTERN int TclFileAttrsCmd _ANSI_ARGS_((Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int TclFileCopyCmd _ANSI_ARGS_((Tcl_Interp *interp, int argc, char **argv)) ; -EXTERN int TclFileDeleteCmd _ANSI_ARGS_((Tcl_Interp *interp, +EXTERN int TclFileDeleteCmd _ANSI_ARGS_((Tcl_Interp *interp, int argc, char **argv)); EXTERN int TclFileMakeDirsCmd _ANSI_ARGS_((Tcl_Interp *interp, int argc, char **argv)) ; @@ -1804,12 +1804,12 @@ EXTERN Proc * TclFindProc _ANSI_ARGS_((Interp *iPtr, EXTERN int TclFormatInt _ANSI_ARGS_((char *buffer, long n)); EXTERN void TclFreePackageInfo _ANSI_ARGS_((Interp *iPtr)); EXTERN void TclGetAndDetachPids _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Channel chan)); + Tcl_Channel chan)); EXTERN int TclGetDate _ANSI_ARGS_((char *p, unsigned long now, long zone, unsigned long *timePtr)); EXTERN Tcl_Obj * TclGetElementOfIndexedArray _ANSI_ARGS_(( - Tcl_Interp *interp, int localIndex, + Tcl_Interp *interp, int localIndex, Tcl_Obj *elemPtr, int leaveErrorMsg)); EXTERN char * TclGetEnv _ANSI_ARGS_((CONST char *name, Tcl_DString *valuePtr)); @@ -1834,23 +1834,23 @@ EXTERN int TclGetNamespaceForQualName _ANSI_ARGS_(( char **simpleNamePtr)); EXTERN TclObjCmdProcType TclGetObjInterpProc _ANSI_ARGS_((void)); EXTERN int TclGetOpenMode _ANSI_ARGS_((Tcl_Interp *interp, - char *string, int *seekFlagPtr)); + char *string, int *seekFlagPtr)); EXTERN Tcl_Command TclGetOriginalCommand _ANSI_ARGS_(( Tcl_Command command)); EXTERN int TclGlob _ANSI_ARGS_((Tcl_Interp *interp, char *pattern, int noComplain)); EXTERN int TclGlobalInvoke _ANSI_ARGS_((Tcl_Interp *interp, - int argc, char **argv, int flags)); + int argc, char **argv, int flags)); EXTERN int TclGuessPackageName _ANSI_ARGS_((char *fileName, Tcl_DString *bufPtr)); EXTERN int TclHideUnsafeCommands _ANSI_ARGS_(( - Tcl_Interp *interp)); + Tcl_Interp *interp)); EXTERN int TclInExit _ANSI_ARGS_((void)); EXTERN Tcl_Obj * TclIncrElementOfIndexedArray _ANSI_ARGS_(( - Tcl_Interp *interp, int localIndex, + Tcl_Interp *interp, int localIndex, Tcl_Obj *elemPtr, long incrAmount)); EXTERN Tcl_Obj * TclIncrIndexedScalar _ANSI_ARGS_(( - Tcl_Interp *interp, int localIndex, + Tcl_Interp *interp, int localIndex, long incrAmount)); EXTERN Tcl_Obj * TclIncrVar2 _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, @@ -1868,13 +1868,13 @@ EXTERN void TclInitObjSubsystem _ANSI_ARGS_((void)); EXTERN void TclInitSubsystems _ANSI_ARGS_((CONST char *argv0)); EXTERN void TclInterpInit _ANSI_ARGS_((Tcl_Interp *interp)); EXTERN int TclInvoke _ANSI_ARGS_((Tcl_Interp *interp, - int argc, char **argv, int flags)); + int argc, char **argv, int flags)); EXTERN int TclInvokeObjectCommand _ANSI_ARGS_(( - ClientData clientData, Tcl_Interp *interp, - int argc, char **argv)); + ClientData clientData, Tcl_Interp *interp, + int argc, char **argv)); EXTERN int TclInvokeStringCommand _ANSI_ARGS_(( - ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[])); + ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[])); EXTERN int TclIsLocalScalar _ANSI_ARGS_((CONST char *src, int len)); EXTERN Proc * TclIsProc _ANSI_ARGS_((Command *cmdPtr)); @@ -1889,17 +1889,17 @@ EXTERN int TclNeedSpace _ANSI_ARGS_((char *start, char *end)); EXTERN Tcl_Obj * TclNewProcBodyObj _ANSI_ARGS_((Proc *procPtr)); EXTERN int TclObjCommandComplete _ANSI_ARGS_((Tcl_Obj *cmdPtr)); EXTERN int TclObjInterpProc _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int TclObjInvoke _ANSI_ARGS_((Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[], int flags)); + int objc, Tcl_Obj *CONST objv[], int flags)); EXTERN int TclObjInvokeGlobal _ANSI_ARGS_((Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[], int flags)); + int objc, Tcl_Obj *CONST objv[], int flags)); EXTERN int TclOpenFileChannelDeleteProc _ANSI_ARGS_(( TclOpenFileChannelProc_ *proc)); EXTERN int TclOpenFileChannelInsertProc _ANSI_ARGS_(( TclOpenFileChannelProc_ *proc)); -EXTERN int TclpAccess _ANSI_ARGS_((CONST char *filename, +EXTERN int TclpAccess _ANSI_ARGS_((CONST char *filename, int mode)); EXTERN char * TclpAlloc _ANSI_ARGS_((unsigned int size)); EXTERN int TclpChdir _ANSI_ARGS_((CONST char *dirName)); @@ -1907,20 +1907,20 @@ EXTERN int TclpCheckStackSpace _ANSI_ARGS_((void)); EXTERN int TclpCloseFile _ANSI_ARGS_((TclFile file)); EXTERN int TclpCopyFile _ANSI_ARGS_((CONST char *source, CONST char *dest)); -EXTERN int TclpCopyDirectory _ANSI_ARGS_((CONST char *source, +EXTERN int TclpCopyDirectory _ANSI_ARGS_((CONST char *source, CONST char *dest, Tcl_DString *errorPtr)); EXTERN Tcl_Channel TclpCreateCommandChannel _ANSI_ARGS_(( - TclFile readFile, TclFile writeFile, + TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr)); -EXTERN int TclpCreateDirectory _ANSI_ARGS_((CONST char *path)); -EXTERN int TclpCreatePipe _ANSI_ARGS_((TclFile *readPipe, +EXTERN int TclpCreateDirectory _ANSI_ARGS_((CONST char *path)); +EXTERN int TclpCreatePipe _ANSI_ARGS_((TclFile *readPipe, TclFile *writePipe)); EXTERN int TclpCreateProcess _ANSI_ARGS_((Tcl_Interp *interp, int argc, char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr)); EXTERN TclFile TclpCreateTempFile _ANSI_ARGS_((CONST char *contents)); -EXTERN int TclpDeleteFile _ANSI_ARGS_((CONST char *path)); +EXTERN int TclpDeleteFile _ANSI_ARGS_((CONST char *path)); EXTERN void TclpExit _ANSI_ARGS_((int status)); EXTERN void TclpFinalizeCondition _ANSI_ARGS_(( Tcl_Condition *condPtr)); @@ -1964,34 +1964,34 @@ EXTERN TclFile TclpOpenFile _ANSI_ARGS_((CONST char *fname, EXTERN Tcl_Channel TclpOpenFileChannel _ANSI_ARGS_((Tcl_Interp *interp, char *fileName, char *modeString, int permissions)); -EXTERN char * TclpReadlink _ANSI_ARGS_((CONST char *fileName, +EXTERN char * TclpReadlink _ANSI_ARGS_((CONST char *fileName, Tcl_DString *linkPtr)); EXTERN char * TclpRealloc _ANSI_ARGS_((char *ptr, unsigned int size)); EXTERN void TclpReleaseFile _ANSI_ARGS_((TclFile file)); -EXTERN int TclpRemoveDirectory _ANSI_ARGS_((CONST char *path, +EXTERN int TclpRemoveDirectory _ANSI_ARGS_((CONST char *path, int recursive, Tcl_DString *errorPtr)); -EXTERN int TclpRenameFile _ANSI_ARGS_((CONST char *source, +EXTERN int TclpRenameFile _ANSI_ARGS_((CONST char *source, CONST char *dest)); EXTERN void TclpSetInitialEncodings _ANSI_ARGS_((void)); EXTERN void TclpSetVariables _ANSI_ARGS_((Tcl_Interp *interp)); -EXTERN VOID * TclpSysAlloc _ANSI_ARGS_((long size, int isBin)); -EXTERN void TclpSysFree _ANSI_ARGS_((VOID *ptr)); -EXTERN VOID * TclpSysRealloc _ANSI_ARGS_((VOID *cp, +EXTERN VOID * TclpSysAlloc _ANSI_ARGS_((long size, int isBin)); +EXTERN void TclpSysFree _ANSI_ARGS_((VOID *ptr)); +EXTERN VOID * TclpSysRealloc _ANSI_ARGS_((VOID *cp, unsigned int size)); EXTERN void TclpUnloadFile _ANSI_ARGS_((ClientData clientData)); EXTERN char * TclPrecTraceProc _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, char *name1, char *name2, int flags)); EXTERN int TclPreventAliasLoop _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Interp *cmdInterp, Tcl_Command cmd)); + Tcl_Interp *cmdInterp, Tcl_Command cmd)); EXTERN void TclProcCleanupProc _ANSI_ARGS_((Proc *procPtr)); EXTERN int TclProcCompileProc _ANSI_ARGS_((Tcl_Interp *interp, - Proc *procPtr, Tcl_Obj *bodyPtr, Namespace *nsPtr, - CONST char *description, CONST char *procName)); + Proc *procPtr, Tcl_Obj *bodyPtr, Namespace *nsPtr, + CONST char *description, CONST char *procName)); EXTERN void TclProcDeleteProc _ANSI_ARGS_((ClientData clientData)); EXTERN int TclProcInterpProc _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); + Tcl_Interp *interp, int argc, char **argv)); EXTERN int TclpThreadCreate _ANSI_ARGS_((Tcl_ThreadId *idPtr, Tcl_ThreadCreateProc proc, ClientData clientData)); EXTERN VOID * TclpThreadDataKeyGet _ANSI_ARGS_(( @@ -2010,7 +2010,7 @@ EXTERN void TclResetShadowedCmdRefs _ANSI_ARGS_(( Tcl_Interp *interp, Command *newCmdPtr)); EXTERN int TclServiceIdle _ANSI_ARGS_((void)); EXTERN Tcl_Obj * TclSetElementOfIndexedArray _ANSI_ARGS_(( - Tcl_Interp *interp, int localIndex, + Tcl_Interp *interp, int localIndex, Tcl_Obj *elemPtr, Tcl_Obj *objPtr, int leaveErrorMsg)); EXTERN void TclSetLibraryPath _ANSI_ARGS_((Tcl_Obj *pathPtr)); @@ -2020,9 +2020,9 @@ EXTERN Tcl_Obj * TclSetIndexedScalar _ANSI_ARGS_((Tcl_Interp *interp, EXTERN char * TclSetPreInitScript _ANSI_ARGS_((char *string)); EXTERN void TclSetupEnv _ANSI_ARGS_((Tcl_Interp *interp)); EXTERN int TclSockGetPort _ANSI_ARGS_((Tcl_Interp *interp, - char *string, char *proto, int *portPtr)); + char *string, char *proto, int *portPtr)); EXTERN int TclSockMinimumBuffers _ANSI_ARGS_((int sock, - int size)); + int size)); EXTERN int TclStat _ANSI_ARGS_((CONST char *path, TclStat_ *buf)); EXTERN int TclStatDeleteProc _ANSI_ARGS_((TclStatProc_ *proc)); @@ -2031,8 +2031,8 @@ EXTERN void TclTeardownNamespace _ANSI_ARGS_((Namespace *nsPtr)); EXTERN int TclTestChannelCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); EXTERN int TclTestChannelEventCmd _ANSI_ARGS_(( - ClientData clientData, Tcl_Interp *interp, - int argc, char **argv)); + ClientData clientData, Tcl_Interp *interp, + int argc, char **argv)); EXTERN void TclTransferResult _ANSI_ARGS_((Tcl_Interp *sourceInterp, int result, Tcl_Interp *targetInterp)); EXTERN int TclUniCharIsAlnum _ANSI_ARGS_((int ch)); @@ -2234,13 +2234,13 @@ EXTERN int Tcl_WhileObjCmd _ANSI_ARGS_((ClientData clientData, */ #ifdef MAC_TCL -EXTERN int Tcl_EchoCmd _ANSI_ARGS_((ClientData clientData, +EXTERN int Tcl_EchoCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_LsObjCmd _ANSI_ARGS_((ClientData clientData, +EXTERN int Tcl_LsObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_BeepObjCmd _ANSI_ARGS_((ClientData clientData, +EXTERN int Tcl_BeepObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_MacSourceObjCmd _ANSI_ARGS_((ClientData clientData, +EXTERN int Tcl_MacSourceObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_ResourceObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); @@ -2304,7 +2304,7 @@ EXTERN int TclCompileWhileCmd _ANSI_ARGS_((Tcl_Interp *interp, #ifdef TCL_MEM_DEBUG # define TclNewObj(objPtr) \ (objPtr) = (Tcl_Obj *) \ - Tcl_DbCkalloc(sizeof(Tcl_Obj), __FILE__, __LINE__); \ + Tcl_DbCkalloc(sizeof(Tcl_Obj), __FILE__, __LINE__); \ (objPtr)->refCount = 0; \ (objPtr)->bytes = tclEmptyStringRep; \ (objPtr)->length = 0; \ @@ -2321,19 +2321,19 @@ EXTERN int TclCompileWhileCmd _ANSI_ARGS_((Tcl_Interp *interp, # define TclDecrRefCount(objPtr) \ if (--(objPtr)->refCount <= 0) { \ - if ((objPtr)->refCount < -1) \ - panic("Reference count for %lx was negative: %s line %d", \ + if ((objPtr)->refCount < -1) \ + panic("Reference count for %lx was negative: %s line %d", \ (objPtr), __FILE__, __LINE__); \ - if (((objPtr)->bytes != NULL) \ - && ((objPtr)->bytes != tclEmptyStringRep)) { \ + if (((objPtr)->bytes != NULL) \ + && ((objPtr)->bytes != tclEmptyStringRep)) { \ ckfree((char *) (objPtr)->bytes); \ - } \ - if (((objPtr)->typePtr != NULL) \ - && ((objPtr)->typePtr->freeIntRepProc != NULL)) { \ + } \ + if (((objPtr)->typePtr != NULL) \ + && ((objPtr)->typePtr->freeIntRepProc != NULL)) { \ (objPtr)->typePtr->freeIntRepProc(objPtr); \ - } \ - ckfree((char *) (objPtr)); \ - TclIncrObjsFreed(); \ + } \ + ckfree((char *) (objPtr)); \ + TclIncrObjsFreed(); \ } #else /* not TCL_MEM_DEBUG */ @@ -2359,18 +2359,18 @@ extern Tcl_Mutex tclObjMutex; # define TclDecrRefCount(objPtr) \ if (--(objPtr)->refCount <= 0) { \ - if (((objPtr)->bytes != NULL) \ - && ((objPtr)->bytes != tclEmptyStringRep)) { \ + if (((objPtr)->bytes != NULL) \ + && ((objPtr)->bytes != tclEmptyStringRep)) { \ ckfree((char *) (objPtr)->bytes); \ - } \ - if (((objPtr)->typePtr != NULL) \ - && ((objPtr)->typePtr->freeIntRepProc != NULL)) { \ + } \ + if (((objPtr)->typePtr != NULL) \ + && ((objPtr)->typePtr->freeIntRepProc != NULL)) { \ (objPtr)->typePtr->freeIntRepProc(objPtr); \ - } \ + } \ Tcl_MutexLock(&tclObjMutex); \ - (objPtr)->internalRep.otherValuePtr = (VOID *) tclFreeObjList; \ - tclFreeObjList = (objPtr); \ - TclIncrObjsFreed(); \ + (objPtr)->internalRep.otherValuePtr = (VOID *) tclFreeObjList; \ + tclFreeObjList = (objPtr); \ + TclIncrObjsFreed(); \ Tcl_MutexUnlock(&tclObjMutex); \ } #endif /* TCL_MEM_DEBUG */ @@ -2391,12 +2391,12 @@ extern Tcl_Mutex tclObjMutex; #define TclInitStringRep(objPtr, bytePtr, len) \ if ((len) == 0) { \ - (objPtr)->bytes = tclEmptyStringRep; \ + (objPtr)->bytes = tclEmptyStringRep; \ (objPtr)->length = 0; \ } else { \ (objPtr)->bytes = (char *) ckalloc((unsigned) ((len) + 1)); \ memcpy((VOID *) (objPtr)->bytes, (VOID *) (bytePtr), \ - (unsigned) (len)); \ + (unsigned) (len)); \ (objPtr)->bytes[len] = '\0'; \ (objPtr)->length = (len); \ } @@ -2425,9 +2425,9 @@ extern Tcl_Mutex tclObjMutex; */ EXTERN void Tcl_AddInterpResolvers _ANSI_ARGS_((Tcl_Interp *interp, - char *name, Tcl_ResolveCmdProc *cmdProc, - Tcl_ResolveVarProc *varProc, - Tcl_ResolveCompiledVarProc *compiledVarProc)); + char *name, Tcl_ResolveCmdProc *cmdProc, + Tcl_ResolveVarProc *varProc, + Tcl_ResolveCompiledVarProc *compiledVarProc)); EXTERN int Tcl_AppendExportList _ANSI_ARGS_(( Tcl_Interp *interp, Tcl_Namespace *nsPtr, Tcl_Obj *objPtr)); @@ -2445,14 +2445,14 @@ EXTERN Tcl_Command Tcl_FindCommand _ANSI_ARGS_((Tcl_Interp *interp, EXTERN Tcl_Namespace * Tcl_FindNamespace _ANSI_ARGS_((Tcl_Interp *interp, char *name, Tcl_Namespace *contextNsPtr, int flags)); -EXTERN int Tcl_GetInterpResolvers _ANSI_ARGS_((Tcl_Interp *interp, - char *name, Tcl_ResolverInfo *resInfo)); -EXTERN int Tcl_GetNamespaceResolvers _ANSI_ARGS_(( +EXTERN int Tcl_GetInterpResolvers _ANSI_ARGS_((Tcl_Interp *interp, + char *name, Tcl_ResolverInfo *resInfo)); +EXTERN int Tcl_GetNamespaceResolvers _ANSI_ARGS_(( Tcl_Namespace *namespacePtr, Tcl_ResolverInfo *resInfo)); EXTERN void Tcl_GetVariableFullName _ANSI_ARGS_(( Tcl_Interp *interp, Tcl_Var variable, - Tcl_Obj *objPtr)); + Tcl_Obj *objPtr)); EXTERN Tcl_Var Tcl_FindNamespaceVar _ANSI_ARGS_(( Tcl_Interp *interp, char *name, Tcl_Namespace *contextNsPtr, int flags)); diff --git a/generic/tclMain.c b/generic/tclMain.c index e8f7f6a..5c6ba10 100644 --- a/generic/tclMain.c +++ b/generic/tclMain.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclMain.c,v 1.1.2.3 1999/02/01 21:29:54 stanton Exp $ + * RCS: @(#) $Id: tclMain.c,v 1.1.2.4 1999/02/10 23:31:17 stanton Exp $ */ #include "tcl.h" @@ -151,8 +151,8 @@ Tcl_Main(argc, argv, appInitProc) */ Tcl_AddErrorInfo(interp, ""); - Tcl_WriteObj(errChannel, - Tcl_GetObjVar2(interp, "errorInfo", NULL, TCL_GLOBAL_ONLY)); + Tcl_WriteObj(errChannel, Tcl_GetVar2Ex(interp, "errorInfo", + NULL, TCL_GLOBAL_ONLY)); Tcl_WriteChars(errChannel, "\n", 1); } exitCode = 1; @@ -184,7 +184,7 @@ Tcl_Main(argc, argv, appInitProc) if (tty) { Tcl_Obj *promptCmdPtr; - promptCmdPtr = Tcl_GetObjVar2(interp, + promptCmdPtr = Tcl_GetVar2Ex(interp, (gotPartial ? "tcl_prompt2" : "tcl_prompt1"), NULL, TCL_GLOBAL_ONLY); if (promptCmdPtr == NULL) { diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 2e8040b..5fbd4a6 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -9,7 +9,7 @@ * * Copyright (c) 1993-1997 Lucent Technologies. * Copyright (c) 1997 Sun Microsystems, Inc. - * Copyright (c) 1998 by Scriptics Corporation. + * Copyright (c) 1998-1999 by Scriptics Corporation. * * Originally implemented by * Michael J. McLennan @@ -19,7 +19,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclNamesp.c,v 1.1.2.6 1999/02/01 21:29:54 stanton Exp $ + * RCS: @(#) $Id: tclNamesp.c,v 1.1.2.7 1999/02/10 23:31:17 stanton Exp $ */ #include "tclInt.h" @@ -288,11 +288,8 @@ Tcl_PushCallFrame(interp, callFramePtr, namespacePtr, isProcCallFrame) } else { nsPtr = (Namespace *) namespacePtr; if (nsPtr->flags & NS_DEAD) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "namespace \"", - nsPtr->fullName, "\" not found in context \"", - Tcl_GetCurrentNamespace(interp)->fullName, "\"", - (char *) NULL); - return TCL_ERROR; + panic("Trying to push call frame for dead namespace"); + /*NOTREACHED*/ } } @@ -448,7 +445,7 @@ Tcl_CreateNamespace(interp, name, clientData, deleteProc) char *simpleName; Tcl_HashEntry *entryPtr; Tcl_DString buffer1, buffer2; - int newEntry, result; + int newEntry; /* * If there is no active namespace, the interpreter is being @@ -472,13 +469,9 @@ Tcl_CreateNamespace(interp, name, clientData, deleteProc) * Find the parent for the new namespace. */ - result = TclGetNamespaceForQualName(interp, name, - (Namespace *) NULL, + TclGetNamespaceForQualName(interp, name, (Namespace *) NULL, /*flags*/ (CREATE_NS_IF_UNKNOWN | TCL_LEAVE_ERR_MSG), &parentPtr, &dummy1Ptr, &dummy2Ptr, &simpleName); - if (result != TCL_OK) { - return NULL; - } /* * If the unqualified name at the end is empty, there were trailing @@ -918,7 +911,7 @@ Tcl_Export(interp, namespacePtr, pattern, resetListFirst) Namespace *nsPtr, *exportNsPtr, *dummyPtr; Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); char *simplePattern, *patternCpy; - int neededElems, len, i, result; + int neededElems, len, i; /* * If the specified namespace is NULL, use the current namespace. @@ -951,12 +944,10 @@ Tcl_Export(interp, namespacePtr, pattern, resetListFirst) * Check that the pattern doesn't have namespace qualifiers. */ - result = TclGetNamespaceForQualName(interp, pattern, nsPtr, + TclGetNamespaceForQualName(interp, pattern, nsPtr, /*flags*/ TCL_LEAVE_ERR_MSG, &exportNsPtr, &dummyPtr, &dummyPtr, &simplePattern); - if (result != TCL_OK) { - return result; - } + if ((exportNsPtr != nsPtr) || (strcmp(pattern, simplePattern) != 0)) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "invalid export pattern \"", pattern, @@ -1166,12 +1157,10 @@ Tcl_Import(interp, namespacePtr, pattern, allowOverwrite) "empty import pattern", -1); return TCL_ERROR; } - result = TclGetNamespaceForQualName(interp, pattern, nsPtr, + TclGetNamespaceForQualName(interp, pattern, nsPtr, /*flags*/ TCL_LEAVE_ERR_MSG, &importNsPtr, &dummyPtr, &dummyPtr, &simplePattern); - if (result != TCL_OK) { - return TCL_ERROR; - } + if (importNsPtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "unknown namespace in import pattern \"", @@ -1336,7 +1325,6 @@ Tcl_ForgetImport(interp, namespacePtr, pattern) register Tcl_HashEntry *hPtr; Tcl_HashSearch search; Command *cmdPtr; - int result; /* * If the specified namespace is NULL, use the current namespace. @@ -1354,12 +1342,10 @@ Tcl_ForgetImport(interp, namespacePtr, pattern) * the end. */ - result = TclGetNamespaceForQualName(interp, pattern, nsPtr, + TclGetNamespaceForQualName(interp, pattern, nsPtr, /*flags*/ TCL_LEAVE_ERR_MSG, &importNsPtr, &dummyPtr, &actualCtxPtr, &simplePattern); - if (result != TCL_OK) { - return result; - } + if (importNsPtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "unknown namespace in namespace forget pattern \"", @@ -1571,15 +1557,14 @@ DeleteImportedCmd(clientData) * final component is stored in *simpleNamePtr. * * Results: - * Ordinarily this procedure returns TCL_OK. It sets *nsPtrPtr and - * *altNsPtrPtr to point to the two possible namespaces which represent - * the last (containing) namespace in the qualified name. If the - * procedure sets either *nsPtrPtr or *altNsPtrPtr to NULL, then the - * search along that path failed. The procedure also stores a pointer - * to the simple name of the final component in *simpleNamePtr. If the - * qualified name is "::" or was treated as a namespace reference - * (FIND_ONLY_NS), the procedure stores a pointer to the - * namespace in *nsPtrPtr, NULL in *altNsPtrPtr, and sets + * It sets *nsPtrPtr and *altNsPtrPtr to point to the two possible + * namespaces which represent the last (containing) namespace in the + * qualified name. If the procedure sets either *nsPtrPtr or *altNsPtrPtr + * to NULL, then the search along that path failed. The procedure also + * stores a pointer to the simple name of the final component in + * *simpleNamePtr. If the qualified name is "::" or was treated as a + * namespace reference (FIND_ONLY_NS), the procedure stores a pointer + * to the namespace in *nsPtrPtr, NULL in *altNsPtrPtr, and sets * *simpleNamePtr to point to an empty string. * * If there is an error, this procedure returns TCL_ERROR. If "flags" @@ -1591,9 +1576,12 @@ DeleteImportedCmd(clientData) * set to the input context namespace pointer in cxtNsPtr. If cxtNsPtr * is NULL, it is set to the current namespace context. * + * For backwards compatibility with the TclPro byte code loader, + * this function always returns TCL_OK. + * * Side effects: - * If flags contains TCL_LEAVE_ERR_MSG and an error is encountered, - * the interpreter's result object will contain an error message. + * If "flags" contains CREATE_NS_IF_UNKNOWN, new namespaces may be + * created. * *---------------------------------------------------------------------- */ @@ -1648,7 +1636,7 @@ TclGetNamespaceForQualName(interp, qualName, cxtNsPtr, flags, char *nsName; Tcl_HashEntry *entryPtr; Tcl_DString buffer; - int len, result; + int len; /* * Determine the context namespace nsPtr in which to start the primary @@ -1773,18 +1761,15 @@ TclGetNamespaceForQualName(interp, qualName, cxtNsPtr, flags, } else if (flags & CREATE_NS_IF_UNKNOWN) { Tcl_CallFrame frame; - result = Tcl_PushCallFrame(interp, &frame, + (void) Tcl_PushCallFrame(interp, &frame, (Tcl_Namespace *) nsPtr, /*isProcCallFrame*/ 0); - if (result != TCL_OK) { - Tcl_DStringFree(&buffer); - return result; - } + nsPtr = (Namespace *) Tcl_CreateNamespace(interp, nsName, (ClientData) NULL, (Tcl_NamespaceDeleteProc *) NULL); Tcl_PopCallFrame(interp); + if (nsPtr == NULL) { - Tcl_DStringFree(&buffer); - return TCL_ERROR; + panic("Could not create namespace '%s'", nsName); } } else { /* namespace not found and wasn't created */ nsPtr = NULL; @@ -1887,7 +1872,6 @@ Tcl_FindNamespace(interp, name, contextNsPtr, flags) { Namespace *nsPtr, *dummy1Ptr, *dummy2Ptr; char *dummy; - int result; /* * Find the namespace(s) that contain the specified namespace name. @@ -1895,12 +1879,9 @@ Tcl_FindNamespace(interp, name, contextNsPtr, flags) * to its last component, a namespace. */ - result = TclGetNamespaceForQualName(interp, name, - (Namespace *) contextNsPtr, /*flags*/ (flags | FIND_ONLY_NS), - &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy); - if (result != TCL_OK) { - return NULL; - } + TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr, + (flags | FIND_ONLY_NS), &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy); + if (nsPtr != NULL) { return (Tcl_Namespace *) nsPtr; } else if (flags & TCL_LEAVE_ERR_MSG) { @@ -2011,12 +1992,8 @@ Tcl_FindCommand(interp, name, contextNsPtr, flags) * Find the namespace(s) that contain the command. */ - result = TclGetNamespaceForQualName(interp, name, - (Namespace *) contextNsPtr, flags, &nsPtr[0], &nsPtr[1], - &cxtNsPtr, &simpleName); - if (result != TCL_OK) { - return (Tcl_Command) NULL; - } + TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr, + flags, &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName); /* * Look for the command in the command table of its namespace. @@ -2145,12 +2122,8 @@ Tcl_FindNamespaceVar(interp, name, contextNsPtr, flags) * Find the namespace(s) that contain the variable. */ - result = TclGetNamespaceForQualName(interp, name, - (Namespace *) contextNsPtr, flags, &nsPtr[0], &nsPtr[1], - &cxtNsPtr, &simpleName); - if (result != TCL_OK) { - return (Tcl_Var) NULL; - } + TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr, + flags, &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName); /* * Look for the variable in the variable table of its namespace. @@ -3785,7 +3758,6 @@ SetNsNameFromAny(interp, objPtr) char *name, *dummy; Namespace *nsPtr, *dummy1Ptr, *dummy2Ptr; register ResolvedNsName *resNamePtr; - int flags, result; /* * Get the string representation. Make it up-to-date if necessary. @@ -3803,12 +3775,8 @@ SetNsNameFromAny(interp, objPtr) * object with a NULL ResolvedNsName* internal rep. */ - flags = ((interp != NULL)? TCL_LEAVE_ERR_MSG : 0) | FIND_ONLY_NS; - result = TclGetNamespaceForQualName(interp, name, (Namespace *) NULL, - flags, &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy); - if (result != TCL_OK) { - return result; - } + TclGetNamespaceForQualName(interp, name, (Namespace *) NULL, + FIND_ONLY_NS, &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy); /* * If we found a namespace, then create a new ResolvedNsName structure diff --git a/generic/tclParse.c b/generic/tclParse.c index 823e5f9..ec35cdf 100644 --- a/generic/tclParse.c +++ b/generic/tclParse.c @@ -14,7 +14,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclParse.c,v 1.1.2.8 1999/02/01 21:29:54 stanton Exp $ + * RCS: @(#) $Id: tclParse.c,v 1.1.2.9 1999/02/10 23:31:18 stanton Exp $ */ #include "tclInt.h" @@ -1213,7 +1213,7 @@ Tcl_EvalTokens(interp, tokenPtr, count) } else { index = NULL; } - valuePtr = Tcl_GetObjVar2(interp, varName, index, + valuePtr = Tcl_GetVar2Ex(interp, varName, index, TCL_LEAVE_ERR_MSG); if (varName != nameBuffer) { ckfree(varName); diff --git a/generic/tclProc.c b/generic/tclProc.c index 4a88fde..0040a45 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclProc.c,v 1.1.2.6 1999/02/01 21:29:55 stanton Exp $ + * RCS: @(#) $Id: tclProc.c,v 1.1.2.7 1999/02/10 23:31:18 stanton Exp $ */ #include "tclInt.h" @@ -71,7 +71,6 @@ Tcl_ProcObjCmd(dummy, interp, objc, objv) Namespace *nsPtr, *altNsPtr, *cxtNsPtr; Tcl_Command cmd; Tcl_DString ds; - int result; if (objc != 4) { Tcl_WrongNumArgs(interp, 1, objv, "name args body"); @@ -85,12 +84,9 @@ Tcl_ProcObjCmd(dummy, interp, objc, objv) */ fullName = TclGetString(objv[1]); - result = TclGetNamespaceForQualName(interp, fullName, - (Namespace *) NULL, TCL_LEAVE_ERR_MSG, - &nsPtr, &altNsPtr, &cxtNsPtr, &procName); - if (result != TCL_OK) { - return result; - } + TclGetNamespaceForQualName(interp, fullName, (Namespace *) NULL, + 0, &nsPtr, &altNsPtr, &cxtNsPtr, &procName); + if (nsPtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't create procedure \"", fullName, diff --git a/generic/tclResult.c b/generic/tclResult.c index f47b06f..3f09149 100644 --- a/generic/tclResult.c +++ b/generic/tclResult.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclResult.c,v 1.1.2.2 1998/10/03 01:56:42 stanton Exp $ + * RCS: @(#) $Id: tclResult.c,v 1.1.2.3 1999/02/10 23:31:19 stanton Exp $ */ #include "tclInt.h" @@ -867,7 +867,7 @@ Tcl_SetObjErrorCode(interp, errorObjPtr) Interp *iPtr; iPtr = (Interp *) interp; - Tcl_SetObjVar2(interp, "errorCode", NULL, errorObjPtr, TCL_GLOBAL_ONLY); + Tcl_SetVar2Ex(interp, "errorCode", NULL, errorObjPtr, TCL_GLOBAL_ONLY); iPtr->flags |= ERROR_CODE_SET; } @@ -936,14 +936,14 @@ TclTransferResult(sourceInterp, result, targetInterp) Tcl_ResetResult(targetInterp); - objPtr = Tcl_GetObjVar2(sourceInterp, "errorInfo", NULL, + objPtr = Tcl_GetVar2Ex(sourceInterp, "errorInfo", NULL, TCL_GLOBAL_ONLY); - Tcl_SetObjVar2(targetInterp, "errorInfo", NULL, objPtr, + Tcl_SetVar2Ex(targetInterp, "errorInfo", NULL, objPtr, TCL_GLOBAL_ONLY); - objPtr = Tcl_GetObjVar2(sourceInterp, "errorCode", NULL, + objPtr = Tcl_GetVar2Ex(sourceInterp, "errorCode", NULL, TCL_GLOBAL_ONLY); - Tcl_SetObjVar2(targetInterp, "errorCode", NULL, objPtr, + Tcl_SetVar2Ex(targetInterp, "errorCode", NULL, objPtr, TCL_GLOBAL_ONLY); ((Interp *) targetInterp)->flags |= (ERR_IN_PROGRESS | ERROR_CODE_SET); diff --git a/generic/tclScan.c b/generic/tclScan.c index 4b00b06..2ec6d4c 100644 --- a/generic/tclScan.c +++ b/generic/tclScan.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclScan.c,v 1.1.2.2 1998/11/18 04:15:46 stanton Exp $ + * RCS: @(#) $Id: tclScan.c,v 1.1.2.3 1999/02/10 23:31:19 stanton Exp $ */ #include "tclInt.h" @@ -1012,8 +1012,7 @@ Tcl_ScanObjCmd(dummy, interp, objc, objv) for (i = 0; i < numVars; i++) { if (objs[i] != NULL) { result++; - if (Tcl_SetObjVar2(interp, Tcl_GetString(objv[i+3]), - NULL, objs[i], 0) == NULL) { + if (Tcl_ObjSetVar2(interp, objv[i+3], NULL, objs[i], 0) == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "couldn't set variable \"", Tcl_GetString(objv[i+3]), "\"", (char *) NULL); diff --git a/generic/tclTest.c b/generic/tclTest.c index c7eba49..578a8fe 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclTest.c,v 1.1.2.11 1999/02/01 21:29:55 stanton Exp $ + * RCS: @(#) $Id: tclTest.c,v 1.1.2.12 1999/02/10 23:31:19 stanton Exp $ */ #define TCL_TEST @@ -254,8 +254,8 @@ static int TestsaveresultCmd _ANSI_ARGS_((ClientData dummy, static void TestsaveresultFree _ANSI_ARGS_((char *blockPtr)); static int TestsetassocdataCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, char **argv)); -static int TestsetnoerrCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int argc, char **argv)); +static int TestsetCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); static int TestsetobjerrorcodeCmd _ANSI_ARGS_(( ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); @@ -282,13 +282,13 @@ static int TestupvarCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, char **argv)); /* - * External initialization routines: + * External (platform specific) initialization routine, these declarations + * explicitly don't use EXTERN since this code does not get compiled + * into the library: */ -EXTERN int TclplatformtestInit _ANSI_ARGS_(( - Tcl_Interp *interp)); -EXTERN int TclThread_Init _ANSI_ARGS_(( - Tcl_Interp *interp)); +extern int TclplatformtestInit _ANSI_ARGS_((Tcl_Interp *interp)); +extern int TclThread_Init _ANSI_ARGS_((Tcl_Interp *interp)); /* *---------------------------------------------------------------------- @@ -404,8 +404,10 @@ Tcltest_Init(interp) (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateCommand(interp, "testsetassocdata", TestsetassocdataCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); - Tcl_CreateCommand(interp, "testsetnoerr", TestsetnoerrCmd, + Tcl_CreateCommand(interp, "testsetnoerr", TestsetCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testseterr", TestsetCmd, + (ClientData) TCL_LEAVE_ERR_MSG, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateObjCommand(interp, "testsetobjerrorcode", TestsetobjerrorcodeCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); @@ -3697,50 +3699,45 @@ NoopObjCmd(unused, interp, objc, objv) /* *---------------------------------------------------------------------- * - * TestsetnoerrCmd -- + * TestsetCmd -- * - * Implements the "testsetnoerr" cmd that is used when testing - * the Tcl_Set/GetVar C Api without TCL_LEAVE_ERR_MSG flag + * Implements the "testset{err,noerr}" cmds that are used when testing + * Tcl_Set/GetVar C Api with/without TCL_LEAVE_ERR_MSG flag * * Results: * A standard Tcl result. * * Side effects: - * None. + * Variables may be set. * *---------------------------------------------------------------------- */ /* ARGSUSED */ -static int -TestsetnoerrCmd(dummy, interp, argc, argv) - ClientData dummy; /* Not used. */ +TestsetCmd(data, interp, argc, argv) + ClientData data; /* Additional flags for Get/SetVar2. */ register Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { + int flags = (int) data; char *value; + if (argc == 2) { - Tcl_SetResult(interp, "before get", TCL_STATIC); - value = Tcl_GetVar2(interp, argv[1], (char *) NULL, 0); - if (value == NULL) { - return TCL_ERROR; - } - Tcl_SetResult(interp, value, TCL_VOLATILE); - return TCL_OK; + Tcl_SetResult(interp, "before get", TCL_STATIC); + value = Tcl_GetVar2(interp, argv[1], (char *) NULL, flags); + if (value == NULL) { + return TCL_ERROR; + } + Tcl_AppendElement(interp, value); + return TCL_OK; } else if (argc == 3) { - char *m1 = "before set"; - char *message=Tcl_Alloc(strlen(m1)+1); - - strcpy(message,m1); - - Tcl_SetResult(interp, message, TCL_DYNAMIC); - - value = Tcl_SetVar2(interp, argv[1], (char *) NULL, argv[2], 0); - if (value == NULL) { - return TCL_ERROR; - } - Tcl_SetResult(interp, value, TCL_VOLATILE); + Tcl_SetResult(interp, "before set", TCL_STATIC); + value = Tcl_SetVar2(interp, argv[1], (char *) NULL, argv[2], flags); + if (value == NULL) { + return TCL_ERROR; + } + Tcl_AppendElement(interp, value); return TCL_OK; } else { Tcl_AppendResult(interp, "wrong # args: should be \"", diff --git a/generic/tclVar.c b/generic/tclVar.c index 12adf5e..ebf45f1 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -9,11 +9,12 @@ * * Copyright (c) 1987-1994 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. + * Copyright (c) 1998-1999 by Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclVar.c,v 1.1.2.3 1998/11/06 21:51:57 stanton Exp $ + * RCS: @(#) $Id: tclVar.c,v 1.1.2.4 1999/02/10 23:31:20 stanton Exp $ */ #include "tclInt.h" @@ -28,7 +29,8 @@ static char *noSuchVar = "no such variable"; static char *isArray = "variable is array"; static char *needArray = "variable isn't array"; static char *noSuchElement = "no such element in array"; -static char *danglingUpvar = "upvar refers to element in deleted array"; +static char *danglingElement = "upvar refers to element in deleted array"; +static char *danglingVar = "upvar refers to variable in deleted namespace"; static char *badNamespace = "parent namespace doesn't exist"; static char *missingName = "missing variable name"; @@ -199,7 +201,7 @@ TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2, if (cxtNsPtr->varResProc) { result = (*cxtNsPtr->varResProc)(interp, part1, - (Tcl_Namespace *) cxtNsPtr, flags, &var); + (Tcl_Namespace *) cxtNsPtr, flags, &var); } else { result = TCL_CONTINUE; } @@ -207,7 +209,7 @@ TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2, while (result == TCL_CONTINUE && resPtr) { if (resPtr->varResProc) { result = (*resPtr->varResProc)(interp, part1, - (Tcl_Namespace *) cxtNsPtr, flags, &var); + (Tcl_Namespace *) cxtNsPtr, flags, &var); } resPtr = resPtr->nextPtr; } @@ -238,27 +240,25 @@ TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2, */ if (((flags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY)) != 0) - || (varFramePtr == NULL) - || !varFramePtr->isProcCallFrame - || (strstr(part1, "::") != NULL)) { + || (varFramePtr == NULL) + || !varFramePtr->isProcCallFrame + || (strstr(part1, "::") != NULL)) { char *tail; + /* + * Don't pass TCL_LEAVE_ERR_MSG, we may yet create the variable, + * or otherwise generate our own error! + */ var = Tcl_FindNamespaceVar(interp, part1, (Tcl_Namespace *) NULL, - flags); + flags & ~TCL_LEAVE_ERR_MSG); if (var != (Tcl_Var) NULL) { varPtr = (Var *) var; } if (varPtr == NULL) { - if (flags & TCL_LEAVE_ERR_MSG) { - Tcl_ResetResult(interp); - } if (createPart1) { /* var wasn't found so create it */ - result = TclGetNamespaceForQualName(interp, part1, - (Namespace *) NULL, flags, &varNsPtr, &dummy1Ptr, - &dummy2Ptr, &tail); - if (result != TCL_OK) { - goto done; - } + TclGetNamespaceForQualName(interp, part1, (Namespace *) NULL, + flags, &varNsPtr, &dummy1Ptr, &dummy2Ptr, &tail); + if (varNsPtr == NULL) { if (flags & TCL_LEAVE_ERR_MSG) { VarErrMsg(interp, part1, part2, msg, badNamespace); @@ -308,7 +308,7 @@ TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2, if (createPart1) { if (tablePtr == NULL) { tablePtr = (Tcl_HashTable *) - ckalloc(sizeof(Tcl_HashTable)); + ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(tablePtr, TCL_STRING_KEYS); varFramePtr->varTablePtr = tablePtr; } @@ -337,7 +337,7 @@ TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2, } } -lookupVarPart2: + lookupVarPart2: if (openParen != NULL) { *openParen = '('; openParen = NULL; @@ -374,10 +374,23 @@ lookupVarPart2: varPtr = NULL; goto done; } + + /* + * Make sure we are not resurrecting a namespace variable from a + * deleted namespace! + */ + if ((varPtr->flags & VAR_IN_HASHTABLE) && (varPtr->hPtr == NULL)) { + if (flags & TCL_LEAVE_ERR_MSG) { + VarErrMsg(interp, part1, part2, msg, danglingVar); + } + varPtr = NULL; + goto done; + } + TclSetVarArray(varPtr); TclClearVarUndefined(varPtr); varPtr->value.tablePtr = - (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); + (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(varPtr->value.tablePtr, TCL_STRING_KEYS); } else if (!TclIsVarArray(varPtr)) { if (flags & TCL_LEAVE_ERR_MSG) { @@ -498,17 +511,65 @@ Tcl_GetVar2(interp, part1, part2, flags) { Tcl_Obj *objPtr; - objPtr = Tcl_GetObjVar2(interp, part1, part2, flags); + objPtr = Tcl_GetVar2Ex(interp, part1, part2, flags); if (objPtr == NULL) { return NULL; } return TclGetString(objPtr); } +/* + *---------------------------------------------------------------------- + * + * Tcl_ObjGetVar2 -- + * + * Return the value of a Tcl variable as a Tcl object, given a + * two-part name consisting of array name and element within array. + * + * Results: + * The return value points to the current object value of the variable + * given by part1Ptr and part2Ptr. If the specified variable doesn't + * exist, or if there is a clash in array usage, then NULL is returned + * and a message will be left in the interpreter's result if the + * TCL_LEAVE_ERR_MSG flag is set. + * + * Side effects: + * The ref count for the returned object is _not_ incremented to + * reflect the returned reference; if you want to keep a reference to + * the object you must increment its ref count yourself. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +Tcl_ObjGetVar2(interp, part1Ptr, part2Ptr, flags) + Tcl_Interp *interp; /* Command interpreter in which variable is + * to be looked up. */ + register Tcl_Obj *part1Ptr; /* Points to an object holding the name of + * an array (if part2 is non-NULL) or the + * name of a variable. */ + register Tcl_Obj *part2Ptr; /* If non-null, points to an object holding + * the name of an element in the array + * part1Ptr. */ + int flags; /* OR-ed combination of TCL_GLOBAL_ONLY, + * TCL_LEAVE_ERR_MSG, and + * TCL_PARSE_PART1 bits. */ +{ + char *part1, *part2; + + part1 = Tcl_GetString(part1Ptr); + if (part2Ptr != NULL) { + part2 = Tcl_GetString(part2Ptr); + } else { + part2 = NULL; + } + + return Tcl_GetVar2Ex(interp, part1, part2, flags); +} /* *---------------------------------------------------------------------- * - * Tcl_GetObjVar2 -- + * Tcl_GetVar2Ex -- * * Return the value of a Tcl variable as a Tcl object, given a * two-part name consisting of array name and element within array. @@ -529,7 +590,7 @@ Tcl_GetVar2(interp, part1, part2, flags) */ Tcl_Obj * -Tcl_GetObjVar2(interp, part1, part2, flags) +Tcl_GetVar2Ex(interp, part1, part2, flags) Tcl_Interp *interp; /* Command interpreter in which variable is * to be looked up. */ char *part1; /* Name of an array (if part2 is non-NULL) @@ -648,15 +709,16 @@ TclGetIndexedScalar(interp, localIndex, leaveErrorMsg) int localCt = varFramePtr->procPtr->numCompiledLocals; if (compiledLocals == NULL) { - fprintf(stderr, "\nTclGetIndexedScalar: can't get local %i in frame with no compiled locals\n", - localIndex); - panic("TclGetIndexedScalar: no compiled locals in frame"); + fprintf(stderr, "\nTclGetIndexedScalar: can't get local %i in frame 0x%x, no compiled locals\n", + localIndex, (unsigned int) varFramePtr); + panic("TclGetIndexedScalar: no compiled locals in frame 0x%x", + (unsigned int) varFramePtr); } if ((localIndex < 0) || (localIndex >= localCt)) { - fprintf(stderr, "\nTclGetIndexedScalar: can't get local %i in frame with %i locals\n", - localIndex, localCt); - panic("TclGetIndexedScalar: can't get local %i in frame with %i locals", - localIndex, localCt); + fprintf(stderr, "\nTclGetIndexedScalar: can't get local %i in frame 0x%x with %i locals\n", + localIndex, (unsigned int) varFramePtr, localCt); + panic("TclGetIndexedScalar: bad local index %i in frame 0x%x", + localIndex, (unsigned int) varFramePtr); } #endif /* TCL_COMPILE_DEBUG */ @@ -769,15 +831,15 @@ TclGetElementOfIndexedArray(interp, localIndex, elemPtr, leaveErrorMsg) if (compiledLocals == NULL) { fprintf(stderr, "\nTclGetElementOfIndexedArray: can't get element of local %i in frame 0x%x, no compiled locals\n", - localIndex, (unsigned int) varFramePtr); + localIndex, (unsigned int) varFramePtr); panic("TclGetIndexedScalar: no compiled locals in frame 0x%x", - (unsigned int) varFramePtr); + (unsigned int) varFramePtr); } if ((localIndex < 0) || (localIndex >= localCt)) { fprintf(stderr, "\nTclGetIndexedScalar: can't get element of local %i in frame 0x%x with %i locals\n", - localIndex, (unsigned int) varFramePtr, localCt); + localIndex, (unsigned int) varFramePtr, localCt); panic("TclGetElementOfIndexedArray: bad local index %i in frame 0x%x", - localIndex, (unsigned int) varFramePtr); + localIndex, (unsigned int) varFramePtr); } #endif /* TCL_COMPILE_DEBUG */ @@ -904,8 +966,7 @@ Tcl_SetObjCmd(dummy, interp, objc, objv) Tcl_Obj *varValueObj; if (objc == 2) { - varValueObj = Tcl_GetObjVar2(interp, TclGetString(objv[1]), NULL, - TCL_LEAVE_ERR_MSG); + varValueObj = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG); if (varValueObj == NULL) { return TCL_ERROR; } @@ -913,8 +974,8 @@ Tcl_SetObjCmd(dummy, interp, objc, objv) return TCL_OK; } else if (objc == 3) { - varValueObj = Tcl_SetObjVar2(interp, TclGetString(objv[1]), NULL, - objv[2], TCL_LEAVE_ERR_MSG); + varValueObj = Tcl_ObjSetVar2(interp, objv[1], NULL, objv[2], + TCL_LEAVE_ERR_MSG); if (varValueObj == NULL) { return TCL_ERROR; } @@ -1008,20 +1069,16 @@ Tcl_SetVar2(interp, part1, part2, newValue, flags) { register Tcl_Obj *valuePtr; Tcl_Obj *varValuePtr; - int length; /* * Create an object holding the variable's new value and use - * Tcl_SetObjVar2 to actually set the variable. + * Tcl_SetVar2Ex to actually set the variable. */ - length = newValue ? strlen(newValue) : 0; - TclNewObj(valuePtr); - TclInitStringRep(valuePtr, newValue, length); + valuePtr = Tcl_NewStringObj(newValue, -1); Tcl_IncrRefCount(valuePtr); - varValuePtr = Tcl_SetObjVar2(interp, part1, part2, valuePtr, - flags); + varValuePtr = Tcl_SetVar2Ex(interp, part1, part2, valuePtr, flags); Tcl_DecrRefCount(valuePtr); /* done with the object */ if (varValuePtr == NULL) { @@ -1033,7 +1090,61 @@ Tcl_SetVar2(interp, part1, part2, newValue, flags) /* *---------------------------------------------------------------------- * - * Tcl_SetObjVar2 -- + * Tcl_ObjSetVar2 -- + * + * This function is the same as Tcl_SetVar2Ex below, except the + * variable names are passed in Tcl object instead of strings. + * + * Results: + * Returns a pointer to the Tcl_Obj holding the new value of the + * variable. If the write operation was disallowed because an array was + * expected but not found (or vice versa), then NULL is returned; if + * the TCL_LEAVE_ERR_MSG flag is set, then an explanatory message will + * be left in the interpreter's result. Note that the returned object + * may not be the same one referenced by newValuePtr; this is because + * variable traces may modify the variable's value. + * + * Side effects: + * The value of the given variable is set. If either the array or the + * entry didn't exist then a new variable is created. + + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +Tcl_ObjSetVar2(interp, part1Ptr, part2Ptr, newValuePtr, flags) + Tcl_Interp *interp; /* Command interpreter in which variable is + * to be found. */ + register Tcl_Obj *part1Ptr; /* Points to an object holding the name of + * an array (if part2 is non-NULL) or the + * name of a variable. */ + register Tcl_Obj *part2Ptr; /* If non-null, points to an object holding + * the name of an element in the array + * part1Ptr. */ + Tcl_Obj *newValuePtr; /* New value for variable. */ + int flags; /* Various flags that tell how to set value: + * any of TCL_GLOBAL_ONLY, + * TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE, + * TCL_LIST_ELEMENT, TCL_LEAVE_ERR_MSG, or + * TCL_PARSE_PART1. */ +{ + char *part1, *part2; + + part1 = Tcl_GetString(part1Ptr); + if (part2Ptr != NULL) { + part2 = Tcl_GetString(part2Ptr); + } else { + part2 = NULL; + } + + return Tcl_SetVar2Ex(interp, part1, part2, newValuePtr, flags); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetVar2Ex -- * * Given a two-part variable name, which may refer either to a scalar * variable or an element of an array, change the value of the variable @@ -1057,7 +1168,7 @@ Tcl_SetVar2(interp, part1, part2, newValue, flags) * and incremented for its new value. If the new value for the variable * is not the same one referenced by newValuePtr (perhaps as a result * of a variable trace), then newValuePtr's ref count is left unchanged - * by Tcl_SetObjVar2. newValuePtr's ref count is also left unchanged if + * by Tcl_SetVar2Ex. newValuePtr's ref count is also left unchanged if * we are appending it as a string value: that is, if "flags" includes * TCL_APPEND_VALUE but not TCL_LIST_ELEMENT. * @@ -1069,7 +1180,7 @@ Tcl_SetVar2(interp, part1, part2, newValue, flags) */ Tcl_Obj * -Tcl_SetObjVar2(interp, part1, part2, newValuePtr, flags) +Tcl_SetVar2Ex(interp, part1, part2, newValuePtr, flags) Tcl_Interp *interp; /* Command interpreter in which variable is * to be found. */ char *part1; /* Name of an array (if part2 is non-NULL) @@ -1098,15 +1209,19 @@ Tcl_SetObjVar2(interp, part1, part2, newValuePtr, flags) /* * If the variable is in a hashtable and its hPtr field is NULL, then we - * have an upvar to an array element where the array was deleted, - * leaving the element dangling at the end of the upvar. Generate an - * error (allowing the variable to be reset would screw up our storage - * allocation and is meaningless anyway). + * may have an upvar to an array element where the array was deleted + * or an upvar to a namespace variable whose namespace was deleted. + * Generate an error (allowing the variable to be reset would screw up + * our storage allocation and is meaningless anyway). */ if ((varPtr->flags & VAR_IN_HASHTABLE) && (varPtr->hPtr == NULL)) { if (flags & TCL_LEAVE_ERR_MSG) { - VarErrMsg(interp, part1, part2, "set", danglingUpvar); + if (TclIsVarArrayElement(varPtr)) { + VarErrMsg(interp, part1, part2, "set", danglingElement); + } else { + VarErrMsg(interp, part1, part2, "set", danglingVar); + } } return NULL; } @@ -1196,7 +1311,7 @@ Tcl_SetObjVar2(interp, part1, part2, newValuePtr, flags) neededBytes = Tcl_ScanElement(bytes, &listFlags); oldValuePtr = Tcl_NewObj(); oldValuePtr->bytes = (char *) - ckalloc((unsigned) (neededBytes + 1)); + ckalloc((unsigned) (neededBytes + 1)); oldValuePtr->length = Tcl_ConvertElement(bytes, oldValuePtr->bytes, listFlags); varPtr->value.objPtr = oldValuePtr; @@ -1323,15 +1438,15 @@ TclSetIndexedScalar(interp, localIndex, newValuePtr, leaveErrorMsg) if (compiledLocals == NULL) { fprintf(stderr, "\nTclSetIndexedScalar: can't set local %i in frame 0x%x, no compiled locals\n", - localIndex, (unsigned int) varFramePtr); + localIndex, (unsigned int) varFramePtr); panic("TclSetIndexedScalar: no compiled locals in frame 0x%x", - (unsigned int) varFramePtr); + (unsigned int) varFramePtr); } if ((localIndex < 0) || (localIndex >= localCt)) { fprintf(stderr, "\nTclSetIndexedScalar: can't set local %i in frame 0x%x with %i locals\n", - localIndex, (unsigned int) varFramePtr, localCt); + localIndex, (unsigned int) varFramePtr, localCt); panic("TclSetIndexedScalar: bad local index %i in frame 0x%x", - localIndex, (unsigned int) varFramePtr); + localIndex, (unsigned int) varFramePtr); } #endif /* TCL_COMPILE_DEBUG */ @@ -1351,15 +1466,19 @@ TclSetIndexedScalar(interp, localIndex, newValuePtr, leaveErrorMsg) /* * If the variable is in a hashtable and its hPtr field is NULL, then we - * have an upvar to an array element where the array was deleted, - * leaving the element dangling at the end of the upvar. Generate an - * error (allowing the variable to be reset would screw up our storage - * allocation and is meaningless anyway). + * may have an upvar to an array element where the array was deleted + * or an upvar to a namespace variable whose namespace was deleted. + * Generate an error (allowing the variable to be reset would screw up + * our storage allocation and is meaningless anyway). */ if ((varPtr->flags & VAR_IN_HASHTABLE) && (varPtr->hPtr == NULL)) { if (leaveErrorMsg) { - VarErrMsg(interp, varName, NULL, "set", danglingUpvar); + if (TclIsVarArrayElement(varPtr)) { + VarErrMsg(interp, varName, NULL, "set", danglingElement); + } else { + VarErrMsg(interp, varName, NULL, "set", danglingVar); + } } return NULL; } @@ -1504,15 +1623,15 @@ TclSetElementOfIndexedArray(interp, localIndex, elemPtr, newValuePtr, if (compiledLocals == NULL) { fprintf(stderr, "\nTclSetElementOfIndexedArray: can't set element of local %i in frame 0x%x, no compiled locals\n", - localIndex, (unsigned int) varFramePtr); + localIndex, (unsigned int) varFramePtr); panic("TclSetIndexedScalar: no compiled locals in frame 0x%x", - (unsigned int) varFramePtr); + (unsigned int) varFramePtr); } if ((localIndex < 0) || (localIndex >= localCt)) { fprintf(stderr, "\nTclSetIndexedScalar: can't set elememt of local %i in frame 0x%x with %i locals\n", - localIndex, (unsigned int) varFramePtr, localCt); + localIndex, (unsigned int) varFramePtr, localCt); panic("TclSetElementOfIndexedArray: bad local index %i in frame 0x%x", - localIndex, (unsigned int) varFramePtr); + localIndex, (unsigned int) varFramePtr); } #endif /* TCL_COMPILE_DEBUG */ @@ -1532,13 +1651,32 @@ TclSetElementOfIndexedArray(interp, localIndex, elemPtr, newValuePtr, } /* + * If the variable is in a hashtable and its hPtr field is NULL, then we + * may have an upvar to an array element where the array was deleted + * or an upvar to a namespace variable whose namespace was deleted. + * Generate an error (allowing the variable to be reset would screw up + * our storage allocation and is meaningless anyway). + */ + + if ((arrayPtr->flags & VAR_IN_HASHTABLE) && (arrayPtr->hPtr == NULL)) { + if (leaveErrorMsg) { + if (TclIsVarArrayElement(arrayPtr)) { + VarErrMsg(interp, arrayName, elem, "set", danglingElement); + } else { + VarErrMsg(interp, arrayName, elem, "set", danglingVar); + } + } + goto errorReturn; + } + + /* * Make sure we're dealing with an array. */ if (TclIsVarUndefined(arrayPtr) && !TclIsVarArrayElement(arrayPtr)) { TclSetVarArray(arrayPtr); arrayPtr->value.tablePtr = - (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); + (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(arrayPtr->value.tablePtr, TCL_STRING_KEYS); TclClearVarUndefined(arrayPtr); } else if (!TclIsVarArray(arrayPtr)) { @@ -1681,17 +1819,10 @@ TclIncrVar2(interp, part1Ptr, part2Ptr, incrAmount, flags) int createdNewObj; /* Set 1 if var's value object is shared * so we must increment a copy (i.e. copy * on write). */ - char *part1 = TclGetString(part1Ptr); long i; int result; - char *index; - if (part2Ptr != NULL) { - index = TclGetString(part2Ptr); - } else { - index = NULL; - } - varValuePtr = Tcl_GetObjVar2(interp, part1, index, flags); + varValuePtr = Tcl_ObjGetVar2(interp, part1Ptr, part2Ptr, flags); if (varValuePtr == NULL) { Tcl_AddObjErrorInfo(interp, "\n (reading value of variable to increment)", -1); @@ -1723,7 +1854,7 @@ TclIncrVar2(interp, part1Ptr, part2Ptr, incrAmount, flags) * Store the variable's new value and run any write traces. */ - resultPtr = Tcl_SetObjVar2(interp, part1, index, varValuePtr, flags); + resultPtr = Tcl_ObjSetVar2(interp, part1Ptr, part2Ptr, varValuePtr, flags); if (resultPtr == NULL) { return NULL; } @@ -1772,7 +1903,7 @@ TclIncrIndexedScalar(interp, localIndex, incrAmount) int result; varValuePtr = TclGetIndexedScalar(interp, localIndex, - /*leaveErrorMsg*/ 1); + /*leaveErrorMsg*/ 1); if (varValuePtr == NULL) { Tcl_AddObjErrorInfo(interp, "\n (reading value of variable to increment)", -1); @@ -1806,7 +1937,7 @@ TclIncrIndexedScalar(interp, localIndex, incrAmount) */ resultPtr = TclSetIndexedScalar(interp, localIndex, varValuePtr, - /*leaveErrorMsg*/ 1); + /*leaveErrorMsg*/ 1); if (resultPtr == NULL) { return NULL; } @@ -1859,7 +1990,7 @@ TclIncrElementOfIndexedArray(interp, localIndex, elemPtr, incrAmount) int result; varValuePtr = TclGetElementOfIndexedArray(interp, localIndex, elemPtr, - /*leaveErrorMsg*/ 1); + /*leaveErrorMsg*/ 1); if (varValuePtr == NULL) { Tcl_AddObjErrorInfo(interp, "\n (reading value of variable to increment)", -1); @@ -1893,8 +2024,8 @@ TclIncrElementOfIndexedArray(interp, localIndex, elemPtr, incrAmount) */ resultPtr = TclSetElementOfIndexedArray(interp, localIndex, elemPtr, - varValuePtr, - /*leaveErrorMsg*/ 1); + varValuePtr, + /*leaveErrorMsg*/ 1); if (resultPtr == NULL) { return NULL; } @@ -2027,7 +2158,7 @@ Tcl_UnsetVar2(interp, part1, part2, flags) ckfree((char *) tracePtr); } for (activePtr = iPtr->activeTracePtr; activePtr != NULL; - activePtr = activePtr->nextPtr) { + activePtr = activePtr->nextPtr) { if (activePtr->varPtr == varPtr) { activePtr->nextTracePtr = NULL; } @@ -2045,7 +2176,7 @@ Tcl_UnsetVar2(interp, part1, part2, flags) dummyVarPtr = &dummyVar; if (TclIsVarArray(dummyVarPtr) && !TclIsVarUndefined(dummyVarPtr)) { DeleteArray(iPtr, part1, dummyVarPtr, - (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) | TCL_TRACE_UNSETS); + (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) | TCL_TRACE_UNSETS); } if (TclIsVarScalar(dummyVarPtr) && (dummyVarPtr->value.objPtr != NULL)) { @@ -2055,9 +2186,7 @@ Tcl_UnsetVar2(interp, part1, part2, flags) } /* - * If the variable was a namespace variable, decrement its reference - * count. We are in the process of destroying its namespace so that - * namespace will no longer "refer" to the variable. + * If the variable was a namespace variable, decrement its reference count. */ if (varPtr->flags & VAR_NAMESPACE_VAR) { @@ -2179,8 +2308,8 @@ Tcl_TraceVar2(interp, part1, part2, flags, proc, clientData) tracePtr->traceProc = proc; tracePtr->clientData = clientData; tracePtr->flags = - flags & (TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS | - TCL_TRACE_ARRAY); + flags & (TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS | + TCL_TRACE_ARRAY); tracePtr->nextPtr = varPtr->tracePtr; varPtr->tracePtr = tracePtr; return TCL_OK; @@ -2270,7 +2399,7 @@ Tcl_UntraceVar2(interp, part1, part2, flags, proc, clientData) flags &= (TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS | TCL_TRACE_ARRAY); for (tracePtr = varPtr->tracePtr, prevPtr = NULL; ; - prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) { + prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) { if (tracePtr == NULL) { return; } @@ -2287,7 +2416,7 @@ Tcl_UntraceVar2(interp, part1, part2, flags, proc, clientData) */ for (activePtr = iPtr->activeTracePtr; activePtr != NULL; - activePtr = activePtr->nextPtr) { + activePtr = activePtr->nextPtr) { if (activePtr->nextTracePtr == tracePtr) { activePtr->nextTracePtr = tracePtr->nextPtr; } @@ -2490,23 +2619,21 @@ Tcl_AppendObjCmd(dummy, interp, objc, objv) register Tcl_Obj *varValuePtr = NULL; /* Initialized to avoid compiler * warning. */ - char *varName; int i; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "varName ?value value ...?"); return TCL_ERROR; } - varName = TclGetString(objv[1]); if (objc == 2) { - varValuePtr = Tcl_GetObjVar2(interp, varName, NULL, TCL_LEAVE_ERR_MSG); + varValuePtr = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG); if (varValuePtr == NULL) { return TCL_ERROR; } } else { for (i = 2; i < objc; i++) { - varValuePtr = Tcl_SetObjVar2(interp, varName, NULL, objv[i], - (TCL_APPEND_VALUE | TCL_LEAVE_ERR_MSG)); + varValuePtr = Tcl_ObjSetVar2(interp, objv[1], (Tcl_Obj *) NULL, + objv[i], (TCL_APPEND_VALUE | TCL_LEAVE_ERR_MSG)); if (varValuePtr == NULL) { return TCL_ERROR; } @@ -2544,16 +2671,15 @@ Tcl_LappendObjCmd(dummy, interp, objc, objv) Tcl_Obj *varValuePtr, *newValuePtr; register List *listRepPtr; register Tcl_Obj **elemPtrs; - char *varName; int numElems, numRequired, createdNewObj, createVar, i, j; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "varName ?value value ...?"); return TCL_ERROR; } - varName = TclGetString(objv[1]); if (objc == 2) { - newValuePtr = Tcl_GetObjVar2(interp, varName, NULL, TCL_LEAVE_ERR_MSG); + newValuePtr = Tcl_ObjGetVar2(interp, objv[1], (Tcl_Obj *) NULL, + (TCL_LEAVE_ERR_MSG)); if (newValuePtr == NULL) { /* * The variable doesn't exist yet. Just create it with an empty @@ -2561,7 +2687,7 @@ Tcl_LappendObjCmd(dummy, interp, objc, objv) */ Tcl_Obj *nullObjPtr = Tcl_NewObj(); - newValuePtr = Tcl_SetObjVar2(interp, varName, NULL, + newValuePtr = Tcl_ObjSetVar2(interp, objv[1], NULL, nullObjPtr, TCL_LEAVE_ERR_MSG); if (newValuePtr == NULL) { Tcl_DecrRefCount(nullObjPtr); /* free unneeded object */ @@ -2570,7 +2696,7 @@ Tcl_LappendObjCmd(dummy, interp, objc, objv) } } else { /* - * We have arguments to append. We used to call Tcl_SetObjVar2 to + * We have arguments to append. We used to call Tcl_SetVar2 to * append each argument one at a time to ensure that traces were run * for each append step. We now append the arguments all at once * because it's faster. Note that a read trace and a write trace for @@ -2581,7 +2707,7 @@ Tcl_LappendObjCmd(dummy, interp, objc, objv) createdNewObj = 0; createVar = 1; - varValuePtr = Tcl_GetObjVar2(interp, varName, NULL, 0); + varValuePtr = Tcl_ObjGetVar2(interp, objv[1], NULL, 0); if (varValuePtr == NULL) { /* * We couldn't read the old value: either the var doesn't yet @@ -2589,7 +2715,7 @@ Tcl_LappendObjCmd(dummy, interp, objc, objv) * create it with Tcl_ObjSetVar2 below. */ - char *p; + char *p, *varName; int nameBytes, i; varName = Tcl_GetStringFromObj(objv[1], &nameBytes); @@ -2635,7 +2761,7 @@ Tcl_LappendObjCmd(dummy, interp, objc, objv) if (numRequired > listRepPtr->maxElemCount) { int newMax = (2 * numRequired); Tcl_Obj **newElemPtrs = (Tcl_Obj **) - ckalloc((unsigned) (newMax * sizeof(Tcl_Obj *))); + ckalloc((unsigned) (newMax * sizeof(Tcl_Obj *))); memcpy((VOID *) newElemPtrs, (VOID *) elemPtrs, (size_t) (numElems * sizeof(Tcl_Obj *))); @@ -2668,7 +2794,7 @@ Tcl_LappendObjCmd(dummy, interp, objc, objv) * was new and we didn't create the variable. */ - newValuePtr = Tcl_SetObjVar2(interp, varName, NULL, varValuePtr, + newValuePtr = Tcl_ObjSetVar2(interp, objv[1], NULL, varValuePtr, TCL_LEAVE_ERR_MSG); if (newValuePtr == NULL) { if (createdNewObj && !createVar) { @@ -2721,8 +2847,8 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) ARRAY_NAMES, ARRAY_NEXTELEMENT, ARRAY_SET, ARRAY_SIZE, ARRAY_STARTSEARCH}; static char *arrayOptions[] = {"anymore", "donesearch", "exists", - "get", "names", "nextelement", "set", "size", "startsearch", - (char *) NULL}; + "get", "names", "nextelement", "set", "size", "startsearch", + (char *) NULL}; Interp *iPtr = (Interp *) interp; Var *varPtr, *arrayPtr; @@ -2829,7 +2955,7 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) varPtr->searchPtr = searchPtr->nextPtr; } else { for (prevPtr = varPtr->searchPtr; ; - prevPtr = prevPtr->nextPtr) { + prevPtr = prevPtr->nextPtr) { if (prevPtr->nextPtr == searchPtr) { prevPtr->nextPtr = searchPtr->nextPtr; break; @@ -2865,7 +2991,7 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) pattern = TclGetString(objv[3]); } for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search); - hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { varPtr2 = (Var *) Tcl_GetHashValue(hPtr); if (TclIsVarUndefined(varPtr2)) { continue; @@ -2883,8 +3009,7 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) return result; } - valuePtr = Tcl_GetObjVar2(interp, - TclGetString(objv[2]), TclGetString(namePtr), + valuePtr = Tcl_ObjGetVar2(interp, objv[2], namePtr, TCL_LEAVE_ERR_MSG); if (valuePtr == NULL) { Tcl_DecrRefCount(namePtr); /* free unneeded name obj */ @@ -2917,7 +3042,7 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) pattern = Tcl_GetString(objv[3]); } for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search); - hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { varPtr2 = (Var *) Tcl_GetHashValue(hPtr); if (TclIsVarUndefined(varPtr2)) { continue; @@ -2996,9 +3121,8 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) } if (listLen > 0) { for (i = 0; i < listLen; i += 2) { - if (Tcl_SetObjVar2(interp, TclGetString(objv[2]), - TclGetString(elemPtrs[i]), elemPtrs[i+1], - TCL_LEAVE_ERR_MSG) == NULL) { + if (Tcl_ObjSetVar2(interp, objv[2], elemPtrs[i], + elemPtrs[i+1], TCL_LEAVE_ERR_MSG) == NULL) { result = TCL_ERROR; break; } @@ -3058,7 +3182,7 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) if (!notArray) { for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search); - hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { varPtr2 = (Var *) Tcl_GetHashValue(hPtr); if (TclIsVarUndefined(varPtr2)) { continue; @@ -3090,7 +3214,7 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) searchPtr->id = varPtr->searchPtr->id + 1; TclFormatInt(string, searchPtr->id); Tcl_AppendStringsToObj(resultPtr, "s-", string, "-", varName, - (char *) NULL); + (char *) NULL); } searchPtr->varPtr = varPtr; searchPtr->nextEntry = Tcl_FirstHashEntry(varPtr->value.tablePtr, @@ -3149,7 +3273,7 @@ MakeUpvar(iPtr, framePtr, otherP1, otherP2, otherFlags, myName, myFlags) Tcl_HashTable *tablePtr; Namespace *nsPtr, *altNsPtr, *dummyNsPtr; char *tail; - int new, result; + int new; /* * Find "other" in "framePtr". If not looking up other in just the @@ -3188,21 +3312,18 @@ MakeUpvar(iPtr, framePtr, otherP1, otherP2, otherFlags, myName, myFlags) varFramePtr = iPtr->varFramePtr; if ((myFlags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY)) - || (varFramePtr == NULL) - || !varFramePtr->isProcCallFrame - || (strstr(myName, "::") != NULL)) { - result = TclGetNamespaceForQualName((Tcl_Interp *) iPtr, myName, - (Namespace *) NULL, (myFlags | TCL_LEAVE_ERR_MSG), - &nsPtr, &altNsPtr, &dummyNsPtr, &tail); - if (result != TCL_OK) { - return result; - } + || (varFramePtr == NULL) + || !varFramePtr->isProcCallFrame + || (strstr(myName, "::") != NULL)) { + TclGetNamespaceForQualName((Tcl_Interp *) iPtr, myName, + (Namespace *) NULL, myFlags, &nsPtr, &altNsPtr, &dummyNsPtr, &tail); + if (nsPtr == NULL) { nsPtr = altNsPtr; } if (nsPtr == NULL) { Tcl_AppendResult((Tcl_Interp *) iPtr, "bad variable name \"", - myName, "\": unknown namespace", (char *) NULL); + myName, "\": unknown namespace", (char *) NULL); return TCL_ERROR; } @@ -3295,11 +3416,11 @@ MakeUpvar(iPtr, framePtr, otherP1, otherP2, otherFlags, myName, myFlags) } } else if (!TclIsVarUndefined(varPtr)) { Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", myName, - "\" already exists", (char *) NULL); + "\" already exists", (char *) NULL); return TCL_ERROR; } else if (varPtr->tracePtr != NULL) { Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", myName, - "\" has traces: can't use for upvar", (char *) NULL); + "\" has traces: can't use for upvar", (char *) NULL); return TCL_ERROR; } } @@ -3606,7 +3727,7 @@ Tcl_VariableObjCmd(dummy, interp, objc, objv) Tcl_Obj *CONST objv[]; /* Argument objects. */ { Interp *iPtr = (Interp *) interp; - char *varName, *tail; + char *varName, *tail, *cp; Var *varPtr, *arrayPtr; Tcl_Obj *varValuePtr; int i, result; @@ -3645,8 +3766,7 @@ Tcl_VariableObjCmd(dummy, interp, objc, objv) */ if (i+1 < objc) { /* a value was specified */ - varValuePtr = Tcl_SetObjVar2(interp, TclGetString(objv[i]), - NULL, objv[i+1], + varValuePtr = Tcl_ObjSetVar2(interp, objv[i], NULL, objv[i+1], (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG)); if (varValuePtr == NULL) { return TCL_ERROR; @@ -3663,17 +3783,17 @@ Tcl_VariableObjCmd(dummy, interp, objc, objv) /* * varName might have a scope qualifier, but the name for the * local "link" variable must be the simple name at the tail. + * + * Locate tail in one pass: drop any prefix after two *or more* + * consecutive ":" characters). */ - for (tail = varName; *tail != '\0'; tail++) { - /* empty body */ - } - while ((tail > varName) - && ((*tail != ':') || (*(tail-1) != ':'))) { - tail--; - } - if (*tail == ':') { - tail++; + for (tail = cp = varName; *cp != '\0'; ) { + if (*cp++ == ':') { + while (*cp++ == ':') { + tail = cp; + } + } } /* @@ -3868,7 +3988,7 @@ CallTraces(iPtr, arrayPtr, varPtr, part1, part2, flags) Tcl_DStringInit(&nameCopy); Tcl_DStringAppend(&nameCopy, part1, (p-part1)); part2 = Tcl_DStringValue(&nameCopy) - + (openParen + 1 - part1); + + (openParen + 1 - part1); part2[-1] = 0; part1 = Tcl_DStringValue(&nameCopy); copiedName = 1; @@ -3889,7 +4009,7 @@ CallTraces(iPtr, arrayPtr, varPtr, part1, part2, flags) arrayPtr->refCount++; active.varPtr = arrayPtr; for (tracePtr = arrayPtr->tracePtr; tracePtr != NULL; - tracePtr = active.nextTracePtr) { + tracePtr = active.nextTracePtr) { active.nextTracePtr = tracePtr->nextPtr; if (!(tracePtr->flags & flags)) { continue; @@ -3915,7 +4035,7 @@ CallTraces(iPtr, arrayPtr, varPtr, part1, part2, flags) } active.varPtr = varPtr; for (tracePtr = varPtr->tracePtr; tracePtr != NULL; - tracePtr = active.nextTracePtr) { + tracePtr = active.nextTracePtr) { active.nextTracePtr = tracePtr->nextPtr; if (!(tracePtr->flags & flags)) { continue; @@ -4047,7 +4167,7 @@ ParseSearchId(interp, varPtr, varName, string) */ for (searchPtr = varPtr->searchPtr; searchPtr != NULL; - searchPtr = searchPtr->nextPtr) { + searchPtr = searchPtr->nextPtr) { if (searchPtr->id == id) { return searchPtr; } @@ -4137,7 +4257,7 @@ TclDeleteVars(iPtr, tablePtr) } for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL; - hPtr = Tcl_NextHashEntry(&search)) { + hPtr = Tcl_NextHashEntry(&search)) { varPtr = (Var *) Tcl_GetHashValue(hPtr); /* @@ -4187,7 +4307,7 @@ TclDeleteVars(iPtr, tablePtr) ckfree((char *) tracePtr); } for (activePtr = iPtr->activeTracePtr; activePtr != NULL; - activePtr = activePtr->nextPtr) { + activePtr = activePtr->nextPtr) { if (activePtr->varPtr == varPtr) { activePtr->nextTracePtr = NULL; } @@ -4311,7 +4431,7 @@ TclDeleteCompiledLocalVars(iPtr, framePtr) ckfree((char *) tracePtr); } for (activePtr = iPtr->activeTracePtr; activePtr != NULL; - activePtr = activePtr->nextPtr) { + activePtr = activePtr->nextPtr) { if (activePtr->varPtr == varPtr) { activePtr->nextTracePtr = NULL; } @@ -4381,7 +4501,7 @@ DeleteArray(iPtr, arrayName, varPtr, flags) DeleteSearches(varPtr); for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search); - hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { elPtr = (Var *) Tcl_GetHashValue(hPtr); if (TclIsVarScalar(elPtr) && (elPtr->value.objPtr != NULL)) { objPtr = elPtr->value.objPtr; @@ -4399,7 +4519,7 @@ DeleteArray(iPtr, arrayName, varPtr, flags) ckfree((char *) tracePtr); } for (activePtr = iPtr->activeTracePtr; activePtr != NULL; - activePtr = activePtr->nextPtr) { + activePtr = activePtr->nextPtr) { if (activePtr->varPtr == elPtr) { activePtr->nextTracePtr = NULL; } @@ -4493,7 +4613,7 @@ VarErrMsg(interp, part1, part2, operation, reason) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "can't ", operation, " \"", part1, - (char *) NULL); + (char *) NULL); if (part2 != NULL) { Tcl_AppendResult(interp, "(", part2, ")", (char *) NULL); } diff --git a/library/auto.tcl b/library/auto.tcl index 075a5d2..748c663 100644 --- a/library/auto.tcl +++ b/library/auto.tcl @@ -3,7 +3,7 @@ # utility procs formerly in init.tcl dealing with auto execution # of commands and can be auto loaded themselves. # -# RCS: @(#) $Id: auto.tcl,v 1.1.2.5 1998/12/02 20:08:05 welch Exp $ +# RCS: @(#) $Id: auto.tcl,v 1.1.2.6 1999/02/10 23:31:20 stanton Exp $ # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1998 Sun Microsystems, Inc. @@ -58,7 +58,7 @@ proc tcl_findLibrary {basename version patch initScript enVarName varName} { # The C application may have hardwired a path, which we honor - if {[info exist the_library]} { + if {[info exist the_library] && [string compare $the_library {}]} { lappend dirs $the_library } else { @@ -72,7 +72,8 @@ proc tcl_findLibrary {basename version patch initScript enVarName varName} { # 2. Relative to the Tcl library - lappend dirs [file join [file dirname [info library]] $basename$version] + lappend dirs [file join [file dirname [info library]] \ + $basename$version] # 3. Various locations relative to the executable # ../lib/foo1.0 (From bin directory in install hierarchy) @@ -88,9 +89,7 @@ proc tcl_findLibrary {basename version patch initScript enVarName varName} { lappend dirs [file join $grandParentDir lib $basename$version] lappend dirs [file join $parentDir library] lappend dirs [file join $grandParentDir library] - if {[string match {*[ab]*} $patch]} { - set ver $patch - } else { + if {![regexp {.*[ab][0-9]*} $patch ver]} { set ver $version } lappend dirs [file join $grandParentDir $basename$ver library] diff --git a/library/http/http.tcl b/library/http/http.tcl index 622801f..2e3f724 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -9,7 +9,7 @@ # See the file "license.terms" for information on usage and # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: http.tcl,v 1.1.2.3 1999/01/29 00:20:46 stanton Exp $ +# RCS: @(#) $Id: http.tcl,v 1.1.2.4 1999/02/10 23:31:21 stanton Exp $ package provide http 2.0 ;# This uses Tcl namespaces @@ -363,9 +363,10 @@ proc http::size {token} { if {[info exists state(-progress)]} { eval $state(-progress) {$token $state(totalsize) $state(currentsize)} } + # At this point the token may have been reset if {([string length $error] != 0)} { Finish $token $error - } elseif {[::eof $s]} { + } elseif {[catch {::eof $s} iseof] || $iseof} { Eof $token } else { CopyStart $s $token diff --git a/library/http2.0/http.tcl b/library/http2.0/http.tcl index 622801f..2e3f724 100644 --- a/library/http2.0/http.tcl +++ b/library/http2.0/http.tcl @@ -9,7 +9,7 @@ # See the file "license.terms" for information on usage and # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: http.tcl,v 1.1.2.3 1999/01/29 00:20:46 stanton Exp $ +# RCS: @(#) $Id: http.tcl,v 1.1.2.4 1999/02/10 23:31:21 stanton Exp $ package provide http 2.0 ;# This uses Tcl namespaces @@ -363,9 +363,10 @@ proc http::size {token} { if {[info exists state(-progress)]} { eval $state(-progress) {$token $state(totalsize) $state(currentsize)} } + # At this point the token may have been reset if {([string length $error] != 0)} { Finish $token $error - } elseif {[::eof $s]} { + } elseif {[catch {::eof $s} iseof] || $iseof} { Eof $token } else { CopyStart $s $token diff --git a/library/http2.1/http.tcl b/library/http2.1/http.tcl index 622801f..2e3f724 100644 --- a/library/http2.1/http.tcl +++ b/library/http2.1/http.tcl @@ -9,7 +9,7 @@ # See the file "license.terms" for information on usage and # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: http.tcl,v 1.1.2.3 1999/01/29 00:20:46 stanton Exp $ +# RCS: @(#) $Id: http.tcl,v 1.1.2.4 1999/02/10 23:31:21 stanton Exp $ package provide http 2.0 ;# This uses Tcl namespaces @@ -363,9 +363,10 @@ proc http::size {token} { if {[info exists state(-progress)]} { eval $state(-progress) {$token $state(totalsize) $state(currentsize)} } + # At this point the token may have been reset if {([string length $error] != 0)} { Finish $token $error - } elseif {[::eof $s]} { + } elseif {[catch {::eof $s} iseof] || $iseof} { Eof $token } else { CopyStart $s $token diff --git a/library/http2.3/http.tcl b/library/http2.3/http.tcl index 622801f..2e3f724 100644 --- a/library/http2.3/http.tcl +++ b/library/http2.3/http.tcl @@ -9,7 +9,7 @@ # See the file "license.terms" for information on usage and # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: http.tcl,v 1.1.2.3 1999/01/29 00:20:46 stanton Exp $ +# RCS: @(#) $Id: http.tcl,v 1.1.2.4 1999/02/10 23:31:21 stanton Exp $ package provide http 2.0 ;# This uses Tcl namespaces @@ -363,9 +363,10 @@ proc http::size {token} { if {[info exists state(-progress)]} { eval $state(-progress) {$token $state(totalsize) $state(currentsize)} } + # At this point the token may have been reset if {([string length $error] != 0)} { Finish $token $error - } elseif {[::eof $s]} { + } elseif {[catch {::eof $s} iseof] || $iseof} { Eof $token } else { CopyStart $s $token diff --git a/library/init.tcl b/library/init.tcl index 6d77e30..712ae30 100644 --- a/library/init.tcl +++ b/library/init.tcl @@ -3,7 +3,7 @@ # Default system startup file for Tcl-based applications. Defines # "unknown" procedure and auto-load facilities. # -# RCS: @(#) $Id: init.tcl,v 1.1.2.5 1999/01/29 00:20:45 stanton Exp $ +# RCS: @(#) $Id: init.tcl,v 1.1.2.6 1999/02/10 23:31:20 stanton Exp $ # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. @@ -42,9 +42,11 @@ if {![info exists auto_path]} { set auto_path "" } } -foreach __dir [list [info library] [file dirname [info library]]] { - if {[lsearch -exact $auto_path $__dir] < 0} { - lappend auto_path $__dir +if {[string compare [info library] {}]} { + foreach __dir [list [info library] [file dirname [info library]]] { + if {[lsearch -exact $auto_path $__dir] < 0} { + lappend auto_path $__dir + } } } if {[info exist tcl_pkgPath]} { @@ -54,7 +56,9 @@ if {[info exist tcl_pkgPath]} { } } } -unset __dir +if {[info exists __dir]} { + unset __dir +} # Windows specific end of initialization diff --git a/mac/tclMacAppInit.c b/mac/tclMacAppInit.c index 6a4ffc7..83f25b2 100644 --- a/mac/tclMacAppInit.c +++ b/mac/tclMacAppInit.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclMacAppInit.c,v 1.1.2.3 1998/11/11 04:08:26 stanton Exp $ + * RCS: @(#) $Id: tclMacAppInit.c,v 1.1.2.4 1999/02/10 23:31:21 stanton Exp $ */ #include "tcl.h" @@ -26,10 +26,10 @@ short InstallConsole _ANSI_ARGS_((short fd)); #endif #ifdef TCL_TEST -EXTERN int Procbodytest_Init _ANSI_ARGS_((Tcl_Interp *interp)); -EXTERN int Procbodytest_SafeInit _ANSI_ARGS_((Tcl_Interp *interp)); -EXTERN int TclObjTest_Init _ANSI_ARGS_((Tcl_Interp *interp)); -EXTERN int Tcltest_Init _ANSI_ARGS_((Tcl_Interp *interp)); +extern int Procbodytest_Init _ANSI_ARGS_((Tcl_Interp *interp)); +extern int Procbodytest_SafeInit _ANSI_ARGS_((Tcl_Interp *interp)); +extern int TclObjTest_Init _ANSI_ARGS_((Tcl_Interp *interp)); +extern int Tcltest_Init _ANSI_ARGS_((Tcl_Interp *interp)); #endif /* TCL_TEST */ /* diff --git a/mac/tclMacInit.c b/mac/tclMacInit.c index 64f6585..9c34c91 100644 --- a/mac/tclMacInit.c +++ b/mac/tclMacInit.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclMacInit.c,v 1.1.2.2 1998/09/24 23:59:12 stanton Exp $ + * RCS: @(#) $Id: tclMacInit.c,v 1.1.2.3 1999/02/10 23:31:22 stanton Exp $ */ #include <AppleEvents.h> @@ -511,7 +511,7 @@ TclpSetVariables(interp) Tcl_SetVar(interp, "tcl_library", str, TCL_GLOBAL_ONLY); if (pathPtr != NULL) { - Tcl_SetObjVar2(interp, "tcl_pkgPath", NULL, pathPtr, TCL_GLOBAL_ONLY); + Tcl_SetVar2Ex(interp, "tcl_pkgPath", NULL, pathPtr, TCL_GLOBAL_ONLY); } Tcl_SetVar2(interp, "tcl_platform", "platform", "macintosh", @@ -588,7 +588,7 @@ Tcl_Init( if (pathPtr == NULL) { pathPtr = Tcl_NewObj(); } - Tcl_SetObjVar2(interp, "auto_path", NULL, pathPtr, TCL_GLOBAL_ONLY); + Tcl_SetVar2Ex(interp, "auto_path", NULL, pathPtr, TCL_GLOBAL_ONLY); return Tcl_Eval(interp, initCmd); } diff --git a/tests/cmdAH.test b/tests/cmdAH.test index 846a6e1..7a8e8e4 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -5,11 +5,12 @@ # generates output for errors. No output means no errors were found. # # Copyright (c) 1996-1998 by Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: cmdAH.test,v 1.1.2.5 1998/12/01 22:48:22 stanton Exp $ +# RCS: @(#) $Id: cmdAH.test,v 1.1.2.6 1999/02/10 23:31:22 stanton Exp $ if {[string compare test [info procs test]] == 1} then {source defs} @@ -925,7 +926,7 @@ test cmdAH-11.34 {Tcl_FileObjCmd: extension} { file extension a\\b.c\\ } {} set num 35 -foreach value {a..b a...b a.c..b ..b} result {..b ...b ..b ..b} { +foreach value {a..b a...b a.c..b ..b} result {.b .b .b .b} { foreach p {unix mac windows} { ; test cmdAH-7.$num {Tcl_FileObjCmd: extension} " testsetplatform $p diff --git a/tests/compile.test b/tests/compile.test index e5995c8..537fdac 100644 --- a/tests/compile.test +++ b/tests/compile.test @@ -5,11 +5,12 @@ # generates output for errors. No output means no errors were found. # # Copyright (c) 1997 by Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: compile.test,v 1.1.2.2 1998/09/24 23:59:21 stanton Exp $ +# RCS: @(#) $Id: compile.test,v 1.1.2.3 1999/02/10 23:31:23 stanton Exp $ if {[string compare test [info procs test]] == 1} then {source defs} @@ -178,6 +179,16 @@ test compile-9.1 {UpdateStringOfByteCode: called for duplicate of compiled empty p } {} +test compile-10.1 {BLACKBOX: exception stack overflow} { + set x {{0}} + set y 0 + while {$y < 100} { + if !$x {incr y} + } +} {} + + + catch {rename p ""} catch {namespace delete test_ns_compile} catch {unset x} diff --git a/tests/interp.test b/tests/interp.test index bfca84b..2e372c5 100644 --- a/tests/interp.test +++ b/tests/interp.test @@ -5,12 +5,12 @@ # generates output for errors. No output means no errors were found. # # Copyright (c) 1995-1996 Sun Microsystems, Inc. -# Copyright (c) 1998 by Scriptics Corporation. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: interp.test,v 1.1.2.4 1998/11/11 04:08:29 stanton Exp $ +# RCS: @(#) $Id: interp.test,v 1.1.2.5 1999/02/10 23:31:23 stanton Exp $ if {[string compare test [info procs test]] == 1} then {source defs} @@ -2321,11 +2321,11 @@ test interp-29.2 {recursion limit inheritance} { } # This test dumps core in Tcl 8.0.3! -#test interp-30.1 {deletion of aliases inside namespaces} { -# set i [interp create] -# $i alias ns::cmd list -# $i alias ns::cmd {} -#} {} +test interp-30.1 {deletion of aliases inside namespaces} { + set i [interp create] + $i alias ns::cmd list + $i alias ns::cmd {} +} {} foreach i [interp slaves] { interp delete $i diff --git a/tests/registry.test b/tests/registry.test index 5196cfb..736d4ae 100644 --- a/tests/registry.test +++ b/tests/registry.test @@ -8,8 +8,9 @@ # auto_path or the registry package must have been loaded already. # # Copyright (c) 1997 by Sun Microsystems, Inc. All rights reserved. +# Copyright (c) 1998-1999 by Scriptics Corporation. # -# RCS: @(#) $Id: registry.test,v 1.1.2.3 1998/11/11 04:08:33 stanton Exp $ +# RCS: @(#) $Id: registry.test,v 1.1.2.4 1999/02/10 23:31:24 stanton Exp $ if {$tcl_platform(platform) != "windows"} { return @@ -125,7 +126,7 @@ test registry-1.23 {argument parsing for registry command} { test registry-2.1 {DeleteKey: bad key} { list [catch {registry delete foo} msg] $msg -} {1 {bad root name "foo": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, or HKEY_CURRENT_CONFIG}} +} {1 {bad root name "foo": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, or HKEY_DYN_DATA}} test registry-2.2 {DeleteKey: bad key} { list [catch {registry delete HKEY_CLASSES_ROOT} msg] $msg } {1 {bad key: cannot delete root keys}} @@ -469,19 +470,19 @@ test registry-9.2 {ParseKeyName: bad keys} { } {1 {bad key "\foobar": must start with a valid root}} test registry-9.3 {ParseKeyName: bad keys} { list [catch {registry values \\\\} msg] $msg -} {1 {ambiguous root name "": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, or HKEY_CURRENT_CONFIG}} +} {1 {ambiguous root name "": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, or HKEY_DYN_DATA}} test registry-9.4 {ParseKeyName: bad keys} { list [catch {registry values \\\\\\} msg] $msg -} {1 {ambiguous root name "": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, or HKEY_CURRENT_CONFIG}} +} {1 {ambiguous root name "": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, or HKEY_DYN_DATA}} test registry-9.5 {ParseKeyName: bad keys} {english} { list [catch {registry values \\\\\\HKEY_CLASSES_ROOT} msg] $msg } {1 {unable to open key: The network address is invalid.}} test registry-9.6 {ParseKeyName: bad keys} { list [catch {registry values \\\\gaspode} msg] $msg -} {1 {ambiguous root name "": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, or HKEY_CURRENT_CONFIG}} +} {1 {ambiguous root name "": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, or HKEY_DYN_DATA}} test registry-9.7 {ParseKeyName: bad keys} { list [catch {registry values foobar} msg] $msg -} {1 {bad root name "foobar": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, or HKEY_CURRENT_CONFIG}} +} {1 {bad root name "foobar": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, or HKEY_DYN_DATA}} test registry-9.8 {ParseKeyName: null keys} { list [catch {registry delete HKEY_CLASSES_ROOT\\} msg] $msg } {1 {bad key: cannot delete root keys}} diff --git a/tests/var.test b/tests/var.test index c4ebe6e..e952d6c 100644 --- a/tests/var.test +++ b/tests/var.test @@ -13,7 +13,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: var.test,v 1.1.2.3 1998/12/04 03:01:27 stanton Exp $ +# RCS: @(#) $Id: var.test,v 1.1.2.4 1999/02/10 23:31:24 stanton Exp $ # if {[string compare test [info procs test]] == 1} then {source defs} @@ -113,6 +113,62 @@ test var-1.14 {TclLookupVar, namespace code ignores ":"s in middle and end of va [expr {[lsearch [info vars] x:y:] != -1}] } } {123 456 789 123 456 789 1 1 1} +test var-1.15 {TclLookupVar, resurrect variable via upvar to deleted namespace: compiled code path} { + namespace eval test_ns_var { + variable foo 2 + } + proc p {} { + variable ::test_ns_var::foo + lappend result [catch {set foo} msg] $msg + namespace delete ::test_ns_var + lappend result [catch {set foo 3} msg] $msg + lappend result [catch {set foo(3) 3} msg] $msg + } + p +} {0 2 1 {can't set "foo": upvar refers to variable in deleted namespace} 1 {can't set "foo(3)": upvar refers to variable in deleted namespace}} +test var-1.16 {TclLookupVar, resurrect variable via upvar to deleted namespace: uncompiled code path} { + namespace eval test_ns_var { + variable result + namespace eval subns { + variable foo 2 + } + upvar 0 subns::foo foo + lappend result [catch {set foo} msg] $msg + namespace delete subns + lappend result [catch {set foo 3} msg] $msg + lappend result [catch {set foo(3) 3} msg] $msg + namespace delete [namespace current] + set result + } +} {0 2 1 {can't set "foo": upvar refers to variable in deleted namespace} 1 {can't set "foo(3)": upvar refers to variable in deleted namespace}} +test var-1.17 {TclLookupVar, resurrect array element via upvar to deleted array: compiled code path} { + namespace eval test_ns_var { + variable result + proc p {} { + array set x {1 2 3 4} + upvar 0 x(1) foo + lappend result [catch {set foo} msg] $msg + unset x + lappend result [catch {set foo 3} msg] $msg + } + set result [p] + namespace delete [namespace current] + set result + } +} {0 2 1 {can't set "foo": upvar refers to element in deleted array}} +test var-1.18 {TclLookupVar, resurrect array element via upvar to deleted array: uncompiled code path} { + namespace eval test_ns_var { + variable result {} + variable x + array set x {1 2 3 4} + upvar 0 x(1) foo + lappend result [catch {set foo} msg] $msg + unset x + lappend result [catch {set foo 3} msg] $msg + namespace delete [namespace current] + set result + } +} {0 2 1 {can't set "foo": upvar refers to element in deleted array}} test var-2.1 {Tcl_LappendObjCmd, create var if new} { catch {unset x} @@ -389,6 +445,16 @@ test var-7.12 {Tcl_VariableObjCmd, variable cmd inside proc creates local link v } p } {{My name is empty} {{}}} +test var-7.13 {Tcl_VariableObjCmd, variable named ":"} { + namespace eval test_ns_var { + variable : {My name is ":"} + proc p {} { + variable : + list [set :] [info vars] + } + p + } +} {{My name is ":"} :} test var-8.1 {TclDeleteVars, "unset" traces are called with fully-qualified var names} { catch {namespace delete test_ns_var} @@ -411,48 +477,98 @@ if {[info commands testsetnoerr] == {}} { puts "This application hasn't been compiled with the \"testsetnoerr\"" puts "command, so I can't test TclSetVar etc." } else { -test var-9.1 {behaviour of TclSetVar without TCL_LEAVE_ERR_MSG flag} { - testsetnoerr v 1 -} 1 -test var-9.2 {behaviour of TclGetVar without TCL_LEAVE_ERR_MSG flag} { - catch {unset v} - list [catch {testsetnoerr v} res] $res; -} {1 {before get}} -test var-9.3 {behaviour of TclGetVar without TCL_LEAVE_ERR_MSG flag} { - catch {unset arr} - set arr(1) 1; - list [catch {testsetnoerr arr} res] $res; -} {1 {before get}} -test var-9.4 {behaviour of TclGetVar without TCL_LEAVE_ERR_MSG flag} { - namespace eval ns {variable v nsv} - testsetnoerr ns::v; -} nsv; -test var-9.5 {behaviour of TclGetVar without TCL_LEAVE_ERR_MSG flag} { - catch {namespace delete ns} - list [catch {testsetnoerr ns::v} res] $res; -} {1 {before get}} -test var-9.6 {behaviour of TclSetVar without TCL_LEAVE_ERR_MSG flag} { - catch {unset arr} - set arr(1) 1; - list [catch {testsetnoerr arr 2} res] $res; -} {1 {before set}} -test var-9.7 {behaviour of TclSetVar without TCL_LEAVE_ERR_MSG flag} { - catch {unset arr} - set arr(1) 1; - list [catch {testsetnoerr arr 2} res] $res; -} {1 {before set}} -test var-9.8 {behaviour of TclSetVar without TCL_LEAVE_ERR_MSG flag} { - # this test currently fails, should not... - # (some namespace function resets the interp while it should not) +test var-9.1 {behaviour of TclGet/SetVar simple get/set} { + catch {unset u}; catch {unset v} + list \ + [set u a; testsetnoerr u] \ + [testsetnoerr v b] \ + [testseterr u] \ + [unset v; testseterr v b] +} [list {before get a} {before set b} {before get a} {before set b}] +test var-9.2 {behaviour of TclGet/SetVar namespace get/set} { + catch {namespace delete ns} + namespace eval ns {variable u a; variable v} + list \ + [testsetnoerr ns::u] \ + [testsetnoerr ns::v b] \ + [testseterr ns::u] \ + [unset ns::v; testseterr ns::v b] +} [list {before get a} {before set b} {before get a} {before set b}] +test var-9.3 {behaviour of TclGetVar no variable} { + catch {unset u} + list \ + [catch {testsetnoerr u} res] $res \ + [catch {testseterr u} res] $res +} {1 {before get} 1 {can't read "u": no such variable}} +test var-9.4 {behaviour of TclGetVar no namespace variable} { + catch {namespace delete ns} + namespace eval ns {} + list \ + [catch {testsetnoerr ns::w} res] $res \ + [catch {testseterr ns::w} res] $res +} {1 {before get} 1 {can't read "ns::w": no such variable}} +test var-9.5 {behaviour of TclGetVar no namespace} { catch {namespace delete ns} - list [catch {testsetnoerr ns::v 1} res] $res; -} {1 {before set}} -test var-9.9 {behaviour of TclSetVar without TCL_LEAVE_ERR_MSG flag} { + list \ + [catch {testsetnoerr ns::u} res] $res \ + [catch {testseterr ns::v} res] $res +} {1 {before get} 1 {can't read "ns::v": no such variable}} +test var-9.6 {behaviour of TclSetVar no namespace} { + catch {namespace delete ns} + list \ + [catch {testsetnoerr ns::v 1} res] $res \ + [catch {testseterr ns::v 1} res] $res +} {1 {before set} 1 {can't set "ns::v": parent namespace doesn't exist}} +test var-9.7 {behaviour of TclGetVar array variable} { + catch {unset arr} + set arr(1) 1; + list \ + [catch {testsetnoerr arr} res] $res \ + [catch {testseterr arr} res] $res +} {1 {before get} 1 {can't read "arr": variable is array}} +test var-9.8 {behaviour of TclSetVar array variable} { + catch {unset arr} + set arr(1) 1 + list \ + [catch {testsetnoerr arr 2} res] $res \ + [catch {testseterr arr 2} res] $res +} {1 {before set} 1 {can't set "arr": variable is array}} +test var-9.9 {behaviour of TclGetVar read trace success} { + proc resetvar {val name elem op} {upvar 1 $name v; set v $val} + catch {unset u}; catch {unset v} + set u 10 + trace var u r [list resetvar 1] + trace var v r [list resetvar 2] + list \ + [testsetnoerr u] \ + [testseterr v] +} {{before get 1} {before get 2}} +test var-9.10 {behaviour of TclGetVar read trace error} { + proc writeonly args {error "write-only"} + set v 456 + trace var v r writeonly + list \ + [catch {testsetnoerr v} msg] $msg \ + [catch {testseterr v} msg] $msg +} {1 {before get} 1 {can't read "v": write-only}} +test var-9.11 {behaviour of TclSetVar write trace success} { + proc doubleval {name elem op} {upvar 1 $name v; set v [expr {2 * $v}]} + catch {unset u}; catch {unset v} + set v 1 + trace var v w doubleval + trace var u w doubleval + list \ + [testsetnoerr u 2] \ + [testseterr v 3] +} {{before set 4} {before set 6}} +test var-9.12 {behaviour of TclSetVar write trace error} { proc readonly args {error "read-only"} set v 456 trace var v w readonly - list [catch {testsetnoerr v 2} msg] $msg -} {1 {before set}} + list \ + [catch {testsetnoerr v 2} msg] $msg $v \ + [catch {testseterr v 3} msg] $msg $v +} {1 {before set} 2 1 {can't set "v": read-only} 3} } test var-10.1 {can't nest arrays with array set} { catch {unset arr} diff --git a/tests/winFCmd.test b/tests/winFCmd.test index 5f1477a..6508524 100644 --- a/tests/winFCmd.test +++ b/tests/winFCmd.test @@ -5,11 +5,12 @@ # generates output for errors. No output means no errors were found. # # Copyright (c) 1996-1997 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: winFCmd.test,v 1.1.2.2 1998/09/24 23:59:40 stanton Exp $ +# RCS: @(#) $Id: winFCmd.test,v 1.1.2.3 1999/02/10 23:31:24 stanton Exp $ # if {[string compare test [info procs test]] == 1} then {source defs} @@ -721,8 +722,8 @@ test winFCmd-7.18 {TraverseWinTree: recurse on files: several files and dir} { createfile td1/tf3 createfile td1/tf4 testfile cpdir td1 td2 - glob td2/* -} {td2/tf1 td2/tf2 td2/td2 td2/tf3 td2/tf4} + lsort [glob td2/*] +} {td2/td2 td2/tf1 td2/tf2 td2/tf3 td2/tf4} test winFCmd-7.19 {TraverseWinTree: call TraversalCopy: DOTREE_POSTD} { cleanup file mkdir td1 diff --git a/tests/winPipe.test b/tests/winPipe.test index 1991abc..25e4b09 100644 --- a/tests/winPipe.test +++ b/tests/winPipe.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: winPipe.test,v 1.1.2.3 1998/11/11 04:08:35 stanton Exp $ +# RCS: @(#) $Id: winPipe.test,v 1.1.2.4 1999/02/10 23:31:24 stanton Exp $ if {($tcl_platform(platform) != "windows") || ($testConfig(stdio) == 0)} { return @@ -387,5 +387,5 @@ if {[catch {set env(TEMP) $env_temp}]} { unset env(TEMP) } -file delete big little stdout stderr nothing +file delete big little stdout stderr nothing echoArgs.tcl return diff --git a/tools/Makefile.in b/tools/Makefile.in index db3da6e..51ae4cc 100644 --- a/tools/Makefile.in +++ b/tools/Makefile.in @@ -6,7 +6,7 @@ # # HTML: 1. Build the html target on Unix -# RCS: @(#) $Id: Makefile.in,v 1.1.2.3 1998/12/10 00:49:46 stanton Exp $ +# RCS: @(#) $Id: Makefile.in,v 1.1.2.4 1999/02/10 23:31:25 stanton Exp $ #TCL = tcl@TCL_VERSION@@TCL_PATCH_LEVEL@ #TK = tk@TCL_VERSION@@TCL_PATCH_LEVEL@ @@ -42,7 +42,7 @@ CC=@CC@ all: core pro: - $(MAKE) PRODOCS="$(PRODOCS)" VER="" rtf + $(MAKE) DOCS="$(PRODOCS)" VER="" rtf core: $(MAKE) DOCS="$(COREDOCS)" rtf diff --git a/tools/tcl.hpj b/tools/tcl.hpj index ac84aef..02c1763 100644 --- a/tools/tcl.hpj +++ b/tools/tcl.hpj @@ -6,12 +6,12 @@ LCID=0x409 0x0 0x0 ;English (United States) REPORT=Yes
CONTENTS=contents
TITLE=Tcl/Tk Reference Manual
-CNT=.\tcl81.cnt
+CNT=tcl81.cnt
COPYRIGHT=Copyright © 1998 Scriptics Corporation
-HLP=.\tcl81.hlp
+HLP=tcl81.hlp
[FILES]
-.\tcl.rtf
+tcl.rtf
[WINDOWS]
main="Tcl/Tk Reference Manual",,0
diff --git a/unix/Makefile.in b/unix/Makefile.in index 71a4611..96276f4 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -5,7 +5,7 @@ # "autoconf" program (constructs like "@foo@" will get replaced in the # actual Makefile. # -# RCS: @(#) $Id: Makefile.in,v 1.1.2.12 1998/12/10 03:28:02 stanton Exp $ +# RCS: @(#) $Id: Makefile.in,v 1.1.2.13 1999/02/10 23:31:25 stanton Exp $ # Current Tcl version; used in various names. @@ -404,7 +404,7 @@ test: tcltest ( echo cd $(TOP_DIR)/tests\; source all ) | ./tcltest # Useful target to launch a built tcltest with the proper path,... -runtest: +runtest: tcltest LD_LIBRARY_PATH=`pwd`:${LD_LIBRARY_PATH}; export LD_LIBRARY_PATH; \ SHLIB_PATH=`pwd`:${SHLIB_PATH}; export SHLIB_PATH; \ TCL_LIBRARY="${TCL_BUILDTIME_LIBRARY}"; export TCL_LIBRARY; \ diff --git a/unix/configure.in b/unix/configure.in index b981eed..0c9f9bf 100644 --- a/unix/configure.in +++ b/unix/configure.in @@ -2,7 +2,7 @@ dnl This file is an input file used by the GNU "autoconf" program to dnl generate the file "configure", which is run during Tcl installation dnl to configure the system for the local environment. AC_INIT(../generic/tcl.h) -# RCS: @(#) $Id: configure.in,v 1.1.2.7 1999/01/29 00:20:47 stanton Exp $ +# RCS: @(#) $Id: configure.in,v 1.1.2.8 1999/02/10 23:31:25 stanton Exp $ TCL_VERSION=8.1 TCL_MAJOR_VERSION=8 @@ -55,6 +55,23 @@ else CFLAGS_WARNING="" fi +#------------------------------------------------------------------------------ +# If we're using GCC, see if the compiler understands -pipe. If so, use it. +# It makes compiling go faster. (This is only a performance feature.) +#------------------------------------------------------------------------------ + +if test -z "$no_pipe"; then +if test -n "$GCC"; then + AC_MSG_CHECKING([if the compiler understands -pipe]) + OLDCC="$CC" + CC="$CC -pipe" + AC_TRY_COMPILE(,, + AC_MSG_RESULT(yes), + CC="$OLDCC" + AC_MSG_RESULT(no)) +fi +fi + #-------------------------------------------------------------------- # Supply substitutes for missing POSIX library procedures, or # set flags so Tcl uses alternate procedures. @@ -731,7 +748,7 @@ case $system in LD_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}' TCL_SHARED_LIB_SUFFIX='${VERSION}\$\{DBGX\}.a' ;; - BSD/OS-2.1*|BSD/OS-3*) + BSD/OS-2.1*|BSD/OS-3*|BSD/OS-4*) SHLIB_CFLAGS="" SHLIB_LD="shlicc -r" SHLIB_LD_LIBS='${LIBS}' @@ -775,7 +792,7 @@ case $system in LD_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}' TCL_SHARED_LIB_SUFFIX='${VERSION}\$\{DBGX\}.a' ;; - IRIX-5.*|IRIX-6.*) + IRIX-5.*|IRIX-6.*|IRIX64-6.5*) SHLIB_CFLAGS="" SHLIB_LD="ld -n32 -shared -rdata_shared" SHLIB_LD_LIBS="" @@ -811,7 +828,7 @@ case $system in ;; Linux*) SHLIB_CFLAGS="-fPIC" - SHLIB_LD_LIBS="" + SHLIB_LD_LIBS="${LIBS}" SHLIB_SUFFIX=".so" if test "$have_dl" = yes; then SHLIB_LD="${CC} -shared" diff --git a/unix/mkLinks b/unix/mkLinks index 494a9ea..2c9d327 100644 --- a/unix/mkLinks +++ b/unix/mkLinks @@ -599,10 +599,6 @@ if test -r ObjectType.3; then rm -f Tcl_GetObjType.3 ln ObjectType.3 Tcl_GetObjType.3 fi -if test -r SetVar.3; then - rm -f Tcl_GetObjVar2.3 - ln SetVar.3 Tcl_GetObjVar2.3 -fi if test -r GetOpnFl.3; then rm -f Tcl_GetOpenFile.3 ln GetOpnFl.3 Tcl_GetOpenFile.3 @@ -647,6 +643,10 @@ if test -r SetVar.3; then rm -f Tcl_GetVar2.3 ln SetVar.3 Tcl_GetVar2.3 fi +if test -r SetVar.3; then + rm -f Tcl_GetVar2Ex.3 + ln SetVar.3 Tcl_GetVar2Ex.3 +fi if test -r OpenFileChnl.3; then rm -f Tcl_Gets.3 ln OpenFileChnl.3 Tcl_Gets.3 @@ -799,6 +799,14 @@ if test -r Utf.3; then rm -f Tcl_NumUtfChars.3 ln Utf.3 Tcl_NumUtfChars.3 fi +if test -r SetVar.3; then + rm -f Tcl_ObjGetVar2.3 + ln SetVar.3 Tcl_ObjGetVar2.3 +fi +if test -r SetVar.3; then + rm -f Tcl_ObjSetVar2.3 + ln SetVar.3 Tcl_ObjSetVar2.3 +fi if test -r OpenFileChnl.3; then rm -f Tcl_OpenCommandChannel.3 ln OpenFileChnl.3 Tcl_OpenCommandChannel.3 @@ -1011,10 +1019,6 @@ if test -r SetResult.3; then rm -f Tcl_SetObjResult.3 ln SetResult.3 Tcl_SetObjResult.3 fi -if test -r SetVar.3; then - rm -f Tcl_SetObjVar2.3 - ln SetVar.3 Tcl_SetObjVar2.3 -fi if test -r SetRecLmt.3; then rm -f Tcl_SetRecursionLimit.3 ln SetRecLmt.3 Tcl_SetRecursionLimit.3 @@ -1051,6 +1055,10 @@ if test -r SetVar.3; then rm -f Tcl_SetVar2.3 ln SetVar.3 Tcl_SetVar2.3 fi +if test -r SetVar.3; then + rm -f Tcl_SetVar2Ex.3 + ln SetVar.3 Tcl_SetVar2Ex.3 +fi if test -r Sleep.3; then rm -f Tcl_Sleep.3 ln Sleep.3 Tcl_Sleep.3 diff --git a/unix/tclAppInit.c b/unix/tclAppInit.c index 90c7aa6..407b036 100644 --- a/unix/tclAppInit.c +++ b/unix/tclAppInit.c @@ -6,11 +6,12 @@ * * Copyright (c) 1993 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. + * Copyright (c) 1998-1999 by Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclAppInit.c,v 1.1.2.3 1998/10/06 02:59:06 stanton Exp $ + * RCS: @(#) $Id: tclAppInit.c,v 1.1.2.4 1999/02/10 23:31:26 stanton Exp $ */ #ifdef TCL_XT_TEST @@ -32,18 +33,18 @@ int *tclDummyMathPtr = (int *) matherr; #include "tclInt.h" -EXTERN int Procbodytest_Init _ANSI_ARGS_((Tcl_Interp *interp)); -EXTERN int Procbodytest_SafeInit _ANSI_ARGS_((Tcl_Interp *interp)); -EXTERN int TclObjTest_Init _ANSI_ARGS_((Tcl_Interp *interp)); -EXTERN int Tcltest_Init _ANSI_ARGS_((Tcl_Interp *interp)); +extern int Procbodytest_Init _ANSI_ARGS_((Tcl_Interp *interp)); +extern int Procbodytest_SafeInit _ANSI_ARGS_((Tcl_Interp *interp)); +extern int TclObjTest_Init _ANSI_ARGS_((Tcl_Interp *interp)); +extern int Tcltest_Init _ANSI_ARGS_((Tcl_Interp *interp)); #ifdef TCL_THREADS -EXTERN int TclThread_Init _ANSI_ARGS_((Tcl_Interp *interp)); +extern int TclThread_Init _ANSI_ARGS_((Tcl_Interp *interp)); #endif #endif /* TCL_TEST */ #ifdef TCL_XT_TEST -EXTERN int Tclxttest_Init _ANSI_ARGS_((Tcl_Interp *interp)); +extern int Tclxttest_Init _ANSI_ARGS_((Tcl_Interp *interp)); #endif /* diff --git a/unix/tclUnixChan.c b/unix/tclUnixChan.c index 276fc8b..ef563d3 100644 --- a/unix/tclUnixChan.c +++ b/unix/tclUnixChan.c @@ -5,11 +5,12 @@ * pipes and TCP sockets. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. + * Copyright (c) 1998-1999 by Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclUnixChan.c,v 1.1.2.3 1999/01/29 00:20:47 stanton Exp $ + * RCS: @(#) $Id: tclUnixChan.c,v 1.1.2.4 1999/02/10 23:31:26 stanton Exp $ */ #include "tclInt.h" /* Internal definitions for Tcl. */ @@ -1734,6 +1735,23 @@ TcpGetOptionProc(instanceData, interp, optionName, dsPtr) len = strlen(optionName); } + if ((len > 1) && (optionName[1] == 'e') && + (strncmp(optionName, "-error", len) == 0)) { + int optlen; + int err, ret; + + optlen = sizeof(int); + ret = getsockopt(statePtr->fd, SOL_SOCKET, SO_ERROR, + (char *)&err, &optlen); + if (ret < 0) { + err = errno; + } + if (err != 0) { + Tcl_DStringAppend(dsPtr, Tcl_ErrnoMsg(err), -1); + } + return TCL_OK; + } + if ((len == 0) || ((len > 1) && (optionName[1] == 'p') && (strncmp(optionName, "-peername", len) == 0))) { diff --git a/unix/tclUnixInit.c b/unix/tclUnixInit.c index d89d8d6..00db7d4 100644 --- a/unix/tclUnixInit.c +++ b/unix/tclUnixInit.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclUnixInit.c,v 1.1.2.4 1998/12/01 22:39:35 stanton Exp $ + * RCS: @(#) $Id: tclUnixInit.c,v 1.1.2.5 1999/02/10 23:31:27 stanton Exp $ */ #include "tclInt.h" @@ -514,7 +514,7 @@ Tcl_Init(interp) if (pathPtr == NULL) { pathPtr = Tcl_NewObj(); } - Tcl_SetObjVar2(interp, "tcl_libPath", NULL, pathPtr, TCL_GLOBAL_ONLY); + Tcl_SetVar2Ex(interp, "tcl_libPath", NULL, pathPtr, TCL_GLOBAL_ONLY); return Tcl_Eval(interp, initScript); } diff --git a/unix/tclXtNotify.c b/unix/tclXtNotify.c index cd8f6b5..06acea3 100644 --- a/unix/tclXtNotify.c +++ b/unix/tclXtNotify.c @@ -1,656 +1,656 @@ -/*
- * tclXtNotify.c --
- *
- * This file contains the notifier driver implementation for the
- * Xt intrinsics.
- *
- * Copyright (c) 1997 by 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: tclXtNotify.c,v 1.1.2.1 1998/09/24 23:59:47 stanton Exp $ - */
-
-#include <X11/Intrinsic.h>
-#include <tclInt.h>
-
-/*
- * This structure is used to keep track of the notifier info for a
- * a registered file.
- */
-
-typedef struct FileHandler {
- int fd;
- int mask; /* Mask of desired events: TCL_READABLE, etc. */
- int readyMask; /* Events that have been seen since the
- last time FileHandlerEventProc was called
- for this file. */
- XtInputId read; /* Xt read callback handle. */
- XtInputId write; /* Xt write callback handle. */
- XtInputId except; /* Xt exception callback handle. */
- Tcl_FileProc *proc; /* Procedure to call, in the style of
- * Tcl_CreateFileHandler. */
- ClientData clientData; /* Argument to pass to proc. */
- struct FileHandler *nextPtr;/* Next in list of all files we care about. */
-} FileHandler;
-
-/*
- * The following structure is what is added to the Tcl event queue when
- * file handlers are ready to fire.
- */
-
-typedef struct FileHandlerEvent {
- Tcl_Event header; /* Information that is standard for
- * all events. */
- int fd; /* File descriptor that is ready. Used
- * to find the FileHandler structure for
- * the file (can't point directly to the
- * FileHandler structure because it could
- * go away while the event is queued). */
-} FileHandlerEvent;
-
-/*
- * The following static structure contains the state information for the
- * Xt based implementation of the Tcl notifier.
- */
-
-static struct NotifierState {
- XtAppContext appContext; /* The context used by the Xt
- * notifier. Can be set with
- * TclSetAppContext. */
- int appContextCreated; /* Was it created by us? */
- XtIntervalId currentTimeout; /* Handle of current timer. */
- FileHandler *firstFileHandlerPtr; /* Pointer to head of file handler
- * list. */
-} notifier;
-
-/*
- * The following static indicates whether this module has been initialized.
- */
-
-static int initialized = 0;
-
-/*
- * Static routines defined in this file.
- */
-
-static int FileHandlerEventProc _ANSI_ARGS_((Tcl_Event *evPtr,
- int flags));
-static void FileProc _ANSI_ARGS_((caddr_t clientData,
- int *source, XtInputId *id));
-static void InitNotifier _ANSI_ARGS_((void));
-static void NotifierExitHandler _ANSI_ARGS_((
- ClientData clientData));
-static void TimerProc _ANSI_ARGS_((caddr_t clientData,
- XtIntervalId *id));
-
-/*
- * Functions defined in this file for use by users of the Xt Notifier:
- */
-
-EXTERN XtAppContext TclSetAppContext _ANSI_ARGS_((XtAppContext ctx));
-
-/*
- *----------------------------------------------------------------------
- *
- * TclSetAppContext --
- *
- * Set the notifier application context.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Sets the application context used by the notifier. Panics if
- * the context is already set when called.
- *
- *----------------------------------------------------------------------
- */
-
-XtAppContext
-TclSetAppContext(appContext)
- XtAppContext appContext;
-{
- if (!initialized) {
- InitNotifier();
- }
-
- /*
- * If we already have a context we check whether we were asked to set a
- * new context. If so, we panic because we try to prevent switching
- * contexts by mistake. Otherwise, we return the one we have.
- */
-
- if (notifier.appContext != NULL) {
- if (appContext != NULL) {
-
- /*
- * We already have a context. We do not allow switching contexts
- * after initialization, so we panic.
- */
-
- panic("TclSetAppContext: multiple application contexts");
-
- }
- } else {
-
- /*
- * If we get here we have not yet gotten a context, so either create
- * one or use the one supplied by our caller.
- */
-
- if (appContext == NULL) {
-
- /*
- * We must create a new context and tell our caller what it is, so
- * she can use it too.
- */
-
- notifier.appContext = XtCreateApplicationContext();
- notifier.appContextCreated = 1;
- } else {
-
- /*
- * Otherwise we remember the context that our caller gave us
- * and use it.
- */
-
- notifier.appContextCreated = 0;
- notifier.appContext = appContext;
- }
- }
-
- return notifier.appContext;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * InitNotifier --
- *
- * Initializes the notifier state.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Creates a new exit handler.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-InitNotifier(void)
-{
- /*
- * Only reinitialize if we are not in exit handling. The notifier
- * can get reinitialized after its own exit handler has run, because
- * of exit handlers for the I/O and timer sub-systems (order dependency).
- */
-
- if (TclInExit()) {
- return;
- }
-
- /*
- * DO NOT create the application context yet; doing so would prevent
- * external applications from setting it for us to their own ones.
- */
-
- initialized = 1;
- memset(¬ifier, 0, sizeof(notifier));
- Tcl_CreateExitHandler(NotifierExitHandler, NULL);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * NotifierExitHandler --
- *
- * This function is called to cleanup the notifier state before
- * Tcl is unloaded.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Destroys the notifier window.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-NotifierExitHandler(
- ClientData clientData) /* Not used. */
-{
- if (notifier.currentTimeout != 0) {
- XtRemoveTimeOut(notifier.currentTimeout);
- }
- for (; notifier.firstFileHandlerPtr != NULL; ) {
- Tcl_DeleteFileHandler(notifier.firstFileHandlerPtr->fd);
- }
- if (notifier.appContextCreated) {
- XtDestroyApplicationContext(notifier.appContext);
- notifier.appContextCreated = 0;
- notifier.appContext = NULL;
- }
- initialized = 0;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_SetTimer --
- *
- * This procedure sets the current notifier timeout value.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Replaces any previous timer.
- *
- *----------------------------------------------------------------------
- */
-
-void
-Tcl_SetTimer(timePtr)
- Tcl_Time *timePtr; /* Timeout value, may be NULL. */
-{
- long timeout;
-
- if (!initialized) {
- InitNotifier();
- }
-
- TclSetAppContext(NULL);
- if (notifier.currentTimeout != 0) {
- XtRemoveTimeOut(notifier.currentTimeout);
- }
- if (timePtr) {
- timeout = timePtr->sec * 1000 + timePtr->usec / 1000;
- notifier.currentTimeout =
- XtAppAddTimeOut(notifier.appContext, (unsigned long) timeout,
- TimerProc, NULL);
- } else {
- notifier.currentTimeout = 0;
- }
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TimerProc --
- *
- * This procedure is the XtTimerCallbackProc used to handle
- * timeouts.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Processes all queued events.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-TimerProc(data, id)
- caddr_t data; /* Not used. */
- XtIntervalId *id;
-{
- if (*id != notifier.currentTimeout) {
- return;
- }
- notifier.currentTimeout = 0;
-
- Tcl_ServiceAll();
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_CreateFileHandler --
- *
- * This procedure registers a file handler with the Xt notifier.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Creates a new file handler structure and registers one or more
- * input procedures with Xt.
- *
- *----------------------------------------------------------------------
- */
-
-void
-Tcl_CreateFileHandler(fd, mask, proc, clientData)
- int fd; /* Handle of stream to watch. */
- int mask; /* OR'ed combination of TCL_READABLE,
- * TCL_WRITABLE, and TCL_EXCEPTION:
- * indicates conditions under which
- * proc should be called. */
- Tcl_FileProc *proc; /* Procedure to call for each
- * selected event. */
- ClientData clientData; /* Arbitrary data to pass to proc. */
-{
- FileHandler *filePtr;
-
- if (!initialized) {
- InitNotifier();
- }
-
- TclSetAppContext(NULL);
-
- for (filePtr = notifier.firstFileHandlerPtr; filePtr != NULL;
- filePtr = filePtr->nextPtr) {
- if (filePtr->fd == fd) {
- break;
- }
- }
- if (filePtr == NULL) {
- filePtr = (FileHandler*) ckalloc(sizeof(FileHandler));
- filePtr->fd = fd;
- filePtr->read = 0;
- filePtr->write = 0;
- filePtr->except = 0;
- filePtr->readyMask = 0;
- filePtr->mask = 0;
- filePtr->nextPtr = notifier.firstFileHandlerPtr;
- notifier.firstFileHandlerPtr = filePtr;
- }
- filePtr->proc = proc;
- filePtr->clientData = clientData;
-
- /*
- * Register the file with the Xt notifier, if it hasn't been done yet.
- */
-
- if (mask & TCL_READABLE) {
- if (!(filePtr->mask & TCL_READABLE)) {
- filePtr->read =
- XtAppAddInput(notifier.appContext, fd, XtInputReadMask,
- FileProc, filePtr);
- }
- } else {
- if (filePtr->mask & TCL_READABLE) {
- XtRemoveInput(filePtr->read);
- }
- }
- if (mask & TCL_WRITABLE) {
- if (!(filePtr->mask & TCL_WRITABLE)) {
- filePtr->write =
- XtAppAddInput(notifier.appContext, fd, XtInputWriteMask,
- FileProc, filePtr);
- }
- } else {
- if (filePtr->mask & TCL_WRITABLE) {
- XtRemoveInput(filePtr->write);
- }
- }
- if (mask & TCL_EXCEPTION) {
- if (!(filePtr->mask & TCL_EXCEPTION)) {
- filePtr->except =
- XtAppAddInput(notifier.appContext, fd, XtInputExceptMask,
- FileProc, filePtr);
- }
- } else {
- if (filePtr->mask & TCL_EXCEPTION) {
- XtRemoveInput(filePtr->except);
- }
- }
- filePtr->mask = mask;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_DeleteFileHandler --
- *
- * Cancel a previously-arranged callback arrangement for
- * a file.
- *
- * Results:
- * None.
- *
- * Side effects:
- * If a callback was previously registered on file, remove it.
- *
- *----------------------------------------------------------------------
- */
-
-void
-Tcl_DeleteFileHandler(fd)
- int fd; /* Stream id for which to remove
- * callback procedure. */
-{
- FileHandler *filePtr, *prevPtr;
-
- if (!initialized) {
- InitNotifier();
- }
-
- TclSetAppContext(NULL);
-
- /*
- * Find the entry for the given file (and return if there
- * isn't one).
- */
-
- for (prevPtr = NULL, filePtr = notifier.firstFileHandlerPtr; ;
- prevPtr = filePtr, filePtr = filePtr->nextPtr) {
- if (filePtr == NULL) {
- return;
- }
- if (filePtr->fd == fd) {
- break;
- }
- }
-
- /*
- * Clean up information in the callback record.
- */
-
- if (prevPtr == NULL) {
- notifier.firstFileHandlerPtr = filePtr->nextPtr;
- } else {
- prevPtr->nextPtr = filePtr->nextPtr;
- }
- if (filePtr->mask & TCL_READABLE) {
- XtRemoveInput(filePtr->read);
- }
- if (filePtr->mask & TCL_WRITABLE) {
- XtRemoveInput(filePtr->write);
- }
- if (filePtr->mask & TCL_EXCEPTION) {
- XtRemoveInput(filePtr->except);
- }
- ckfree((char *) filePtr);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * FileProc --
- *
- * These procedures are called by Xt when a file becomes readable,
- * writable, or has an exception.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Makes an entry on the Tcl event queue if the event is
- * interesting.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-FileProc(clientData, fd, id)
- caddr_t clientData;
- int *fd;
- XtInputId *id;
-{
- FileHandler *filePtr = (FileHandler *)clientData;
- FileHandlerEvent *fileEvPtr;
- int mask = 0;
-
- /*
- * Determine which event happened.
- */
-
- if (*id == filePtr->read) {
- mask = TCL_READABLE;
- } else if (*id == filePtr->write) {
- mask = TCL_WRITABLE;
- } else if (*id == filePtr->except) {
- mask = TCL_EXCEPTION;
- }
-
- /*
- * Ignore unwanted or duplicate events.
- */
-
- if (!(filePtr->mask & mask) || (filePtr->readyMask & mask)) {
- return;
- }
-
- /*
- * This is an interesting event, so put it onto the event queue.
- */
-
- filePtr->readyMask |= mask;
- fileEvPtr = (FileHandlerEvent *) ckalloc(sizeof(FileHandlerEvent));
- fileEvPtr->header.proc = FileHandlerEventProc;
- fileEvPtr->fd = filePtr->fd;
- Tcl_QueueEvent((Tcl_Event *) fileEvPtr, TCL_QUEUE_TAIL);
-
- /*
- * Process events on the Tcl event queue before returning to Xt.
- */
-
- Tcl_ServiceAll();
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * FileHandlerEventProc --
- *
- * This procedure is called by Tcl_ServiceEvent when a file event
- * reaches the front of the event queue. This procedure is
- * responsible for actually handling the event by invoking the
- * callback for the file handler.
- *
- * Results:
- * Returns 1 if the event was handled, meaning it should be removed
- * from the queue. Returns 0 if the event was not handled, meaning
- * it should stay on the queue. The only time the event isn't
- * handled is if the TCL_FILE_EVENTS flag bit isn't set.
- *
- * Side effects:
- * Whatever the file handler's callback procedure does.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-FileHandlerEventProc(evPtr, flags)
- Tcl_Event *evPtr; /* Event to service. */
- int flags; /* Flags that indicate what events to
- * handle, such as TCL_FILE_EVENTS. */
-{
- FileHandler *filePtr;
- FileHandlerEvent *fileEvPtr = (FileHandlerEvent *) evPtr;
- int mask;
-
- if (!(flags & TCL_FILE_EVENTS)) {
- return 0;
- }
-
- /*
- * Search through the file handlers to find the one whose handle matches
- * the event. We do this rather than keeping a pointer to the file
- * handler directly in the event, so that the handler can be deleted
- * while the event is queued without leaving a dangling pointer.
- */
-
- for (filePtr = notifier.firstFileHandlerPtr; filePtr != NULL;
- filePtr = filePtr->nextPtr) {
- if (filePtr->fd != fileEvPtr->fd) {
- continue;
- }
-
- /*
- * The code is tricky for two reasons:
- * 1. The file handler's desired events could have changed
- * since the time when the event was queued, so AND the
- * ready mask with the desired mask.
- * 2. The file could have been closed and re-opened since
- * the time when the event was queued. This is why the
- * ready mask is stored in the file handler rather than
- * the queued event: it will be zeroed when a new
- * file handler is created for the newly opened file.
- */
-
- mask = filePtr->readyMask & filePtr->mask;
- filePtr->readyMask = 0;
- if (mask != 0) {
- (*filePtr->proc)(filePtr->clientData, mask);
- }
- break;
- }
- return 1;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_WaitForEvent --
- *
- * This function is called by Tcl_DoOneEvent to wait for new
- * events on the message queue. If the block time is 0, then
- * Tcl_WaitForEvent just polls without blocking.
- *
- * Results:
- * Returns 1 if an event was found, else 0. This ensures that
- * Tcl_DoOneEvent will return 1, even if the event is handled
- * by non-Tcl code.
- *
- * Side effects:
- * Queues file events that are detected by the select.
- *
- *----------------------------------------------------------------------
- */
-
-int
-Tcl_WaitForEvent(
- Tcl_Time *timePtr) /* Maximum block time, or NULL. */
-{
- int timeout;
-
- if (!initialized) {
- InitNotifier();
- }
-
- TclSetAppContext(NULL);
-
- if (timePtr) {
- timeout = timePtr->sec * 1000 + timePtr->usec / 1000;
- if (timeout == 0) {
- if (XtAppPending(notifier.appContext)) {
- goto process;
- } else {
- return 0;
- }
- } else {
- Tcl_SetTimer(timePtr);
- }
- }
-process:
- XtAppProcessEvent(notifier.appContext, XtIMAll);
- return 1;
-}
+/* + * tclXtNotify.c -- + * + * This file contains the notifier driver implementation for the + * Xt intrinsics. + * + * Copyright (c) 1997 by 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: tclXtNotify.c,v 1.1.2.2 1999/02/10 23:31:27 stanton Exp $ + */ + +#include <X11/Intrinsic.h> +#include <tclInt.h> + +/* + * This structure is used to keep track of the notifier info for a + * a registered file. + */ + +typedef struct FileHandler { + int fd; + int mask; /* Mask of desired events: TCL_READABLE, etc. */ + int readyMask; /* Events that have been seen since the + last time FileHandlerEventProc was called + for this file. */ + XtInputId read; /* Xt read callback handle. */ + XtInputId write; /* Xt write callback handle. */ + XtInputId except; /* Xt exception callback handle. */ + Tcl_FileProc *proc; /* Procedure to call, in the style of + * Tcl_CreateFileHandler. */ + ClientData clientData; /* Argument to pass to proc. */ + struct FileHandler *nextPtr;/* Next in list of all files we care about. */ +} FileHandler; + +/* + * The following structure is what is added to the Tcl event queue when + * file handlers are ready to fire. + */ + +typedef struct FileHandlerEvent { + Tcl_Event header; /* Information that is standard for + * all events. */ + int fd; /* File descriptor that is ready. Used + * to find the FileHandler structure for + * the file (can't point directly to the + * FileHandler structure because it could + * go away while the event is queued). */ +} FileHandlerEvent; + +/* + * The following static structure contains the state information for the + * Xt based implementation of the Tcl notifier. + */ + +static struct NotifierState { + XtAppContext appContext; /* The context used by the Xt + * notifier. Can be set with + * TclSetAppContext. */ + int appContextCreated; /* Was it created by us? */ + XtIntervalId currentTimeout; /* Handle of current timer. */ + FileHandler *firstFileHandlerPtr; /* Pointer to head of file handler + * list. */ +} notifier; + +/* + * The following static indicates whether this module has been initialized. + */ + +static int initialized = 0; + +/* + * Static routines defined in this file. + */ + +static int FileHandlerEventProc _ANSI_ARGS_((Tcl_Event *evPtr, + int flags)); +static void FileProc _ANSI_ARGS_((caddr_t clientData, + int *source, XtInputId *id)); +static void InitNotifier _ANSI_ARGS_((void)); +static void NotifierExitHandler _ANSI_ARGS_(( + ClientData clientData)); +static void TimerProc _ANSI_ARGS_((caddr_t clientData, + XtIntervalId *id)); + +/* + * Functions defined in this file for use by users of the Xt Notifier: + */ + +EXTERN XtAppContext TclSetAppContext _ANSI_ARGS_((XtAppContext ctx)); + +/* + *---------------------------------------------------------------------- + * + * TclSetAppContext -- + * + * Set the notifier application context. + * + * Results: + * None. + * + * Side effects: + * Sets the application context used by the notifier. Panics if + * the context is already set when called. + * + *---------------------------------------------------------------------- + */ + +XtAppContext +TclSetAppContext(appContext) + XtAppContext appContext; +{ + if (!initialized) { + InitNotifier(); + } + + /* + * If we already have a context we check whether we were asked to set a + * new context. If so, we panic because we try to prevent switching + * contexts by mistake. Otherwise, we return the one we have. + */ + + if (notifier.appContext != NULL) { + if (appContext != NULL) { + + /* + * We already have a context. We do not allow switching contexts + * after initialization, so we panic. + */ + + panic("TclSetAppContext: multiple application contexts"); + + } + } else { + + /* + * If we get here we have not yet gotten a context, so either create + * one or use the one supplied by our caller. + */ + + if (appContext == NULL) { + + /* + * We must create a new context and tell our caller what it is, so + * she can use it too. + */ + + notifier.appContext = XtCreateApplicationContext(); + notifier.appContextCreated = 1; + } else { + + /* + * Otherwise we remember the context that our caller gave us + * and use it. + */ + + notifier.appContextCreated = 0; + notifier.appContext = appContext; + } + } + + return notifier.appContext; +} + +/* + *---------------------------------------------------------------------- + * + * InitNotifier -- + * + * Initializes the notifier state. + * + * Results: + * None. + * + * Side effects: + * Creates a new exit handler. + * + *---------------------------------------------------------------------- + */ + +static void +InitNotifier(void) +{ + /* + * Only reinitialize if we are not in exit handling. The notifier + * can get reinitialized after its own exit handler has run, because + * of exit handlers for the I/O and timer sub-systems (order dependency). + */ + + if (TclInExit()) { + return; + } + + /* + * DO NOT create the application context yet; doing so would prevent + * external applications from setting it for us to their own ones. + */ + + initialized = 1; + memset(¬ifier, 0, sizeof(notifier)); + Tcl_CreateExitHandler(NotifierExitHandler, NULL); +} + +/* + *---------------------------------------------------------------------- + * + * NotifierExitHandler -- + * + * This function is called to cleanup the notifier state before + * Tcl is unloaded. + * + * Results: + * None. + * + * Side effects: + * Destroys the notifier window. + * + *---------------------------------------------------------------------- + */ + +static void +NotifierExitHandler( + ClientData clientData) /* Not used. */ +{ + if (notifier.currentTimeout != 0) { + XtRemoveTimeOut(notifier.currentTimeout); + } + for (; notifier.firstFileHandlerPtr != NULL; ) { + Tcl_DeleteFileHandler(notifier.firstFileHandlerPtr->fd); + } + if (notifier.appContextCreated) { + XtDestroyApplicationContext(notifier.appContext); + notifier.appContextCreated = 0; + notifier.appContext = NULL; + } + initialized = 0; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetTimer -- + * + * This procedure sets the current notifier timeout value. + * + * Results: + * None. + * + * Side effects: + * Replaces any previous timer. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SetTimer(timePtr) + Tcl_Time *timePtr; /* Timeout value, may be NULL. */ +{ + long timeout; + + if (!initialized) { + InitNotifier(); + } + + TclSetAppContext(NULL); + if (notifier.currentTimeout != 0) { + XtRemoveTimeOut(notifier.currentTimeout); + } + if (timePtr) { + timeout = timePtr->sec * 1000 + timePtr->usec / 1000; + notifier.currentTimeout = + XtAppAddTimeOut(notifier.appContext, (unsigned long) timeout, + TimerProc, NULL); + } else { + notifier.currentTimeout = 0; + } +} + +/* + *---------------------------------------------------------------------- + * + * TimerProc -- + * + * This procedure is the XtTimerCallbackProc used to handle + * timeouts. + * + * Results: + * None. + * + * Side effects: + * Processes all queued events. + * + *---------------------------------------------------------------------- + */ + +static void +TimerProc(data, id) + caddr_t data; /* Not used. */ + XtIntervalId *id; +{ + if (*id != notifier.currentTimeout) { + return; + } + notifier.currentTimeout = 0; + + Tcl_ServiceAll(); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CreateFileHandler -- + * + * This procedure registers a file handler with the Xt notifier. + * + * Results: + * None. + * + * Side effects: + * Creates a new file handler structure and registers one or more + * input procedures with Xt. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_CreateFileHandler(fd, mask, proc, clientData) + int fd; /* Handle of stream to watch. */ + int mask; /* OR'ed combination of TCL_READABLE, + * TCL_WRITABLE, and TCL_EXCEPTION: + * indicates conditions under which + * proc should be called. */ + Tcl_FileProc *proc; /* Procedure to call for each + * selected event. */ + ClientData clientData; /* Arbitrary data to pass to proc. */ +{ + FileHandler *filePtr; + + if (!initialized) { + InitNotifier(); + } + + TclSetAppContext(NULL); + + for (filePtr = notifier.firstFileHandlerPtr; filePtr != NULL; + filePtr = filePtr->nextPtr) { + if (filePtr->fd == fd) { + break; + } + } + if (filePtr == NULL) { + filePtr = (FileHandler*) ckalloc(sizeof(FileHandler)); + filePtr->fd = fd; + filePtr->read = 0; + filePtr->write = 0; + filePtr->except = 0; + filePtr->readyMask = 0; + filePtr->mask = 0; + filePtr->nextPtr = notifier.firstFileHandlerPtr; + notifier.firstFileHandlerPtr = filePtr; + } + filePtr->proc = proc; + filePtr->clientData = clientData; + + /* + * Register the file with the Xt notifier, if it hasn't been done yet. + */ + + if (mask & TCL_READABLE) { + if (!(filePtr->mask & TCL_READABLE)) { + filePtr->read = + XtAppAddInput(notifier.appContext, fd, XtInputReadMask, + FileProc, filePtr); + } + } else { + if (filePtr->mask & TCL_READABLE) { + XtRemoveInput(filePtr->read); + } + } + if (mask & TCL_WRITABLE) { + if (!(filePtr->mask & TCL_WRITABLE)) { + filePtr->write = + XtAppAddInput(notifier.appContext, fd, XtInputWriteMask, + FileProc, filePtr); + } + } else { + if (filePtr->mask & TCL_WRITABLE) { + XtRemoveInput(filePtr->write); + } + } + if (mask & TCL_EXCEPTION) { + if (!(filePtr->mask & TCL_EXCEPTION)) { + filePtr->except = + XtAppAddInput(notifier.appContext, fd, XtInputExceptMask, + FileProc, filePtr); + } + } else { + if (filePtr->mask & TCL_EXCEPTION) { + XtRemoveInput(filePtr->except); + } + } + filePtr->mask = mask; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DeleteFileHandler -- + * + * Cancel a previously-arranged callback arrangement for + * a file. + * + * Results: + * None. + * + * Side effects: + * If a callback was previously registered on file, remove it. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DeleteFileHandler(fd) + int fd; /* Stream id for which to remove + * callback procedure. */ +{ + FileHandler *filePtr, *prevPtr; + + if (!initialized) { + InitNotifier(); + } + + TclSetAppContext(NULL); + + /* + * Find the entry for the given file (and return if there + * isn't one). + */ + + for (prevPtr = NULL, filePtr = notifier.firstFileHandlerPtr; ; + prevPtr = filePtr, filePtr = filePtr->nextPtr) { + if (filePtr == NULL) { + return; + } + if (filePtr->fd == fd) { + break; + } + } + + /* + * Clean up information in the callback record. + */ + + if (prevPtr == NULL) { + notifier.firstFileHandlerPtr = filePtr->nextPtr; + } else { + prevPtr->nextPtr = filePtr->nextPtr; + } + if (filePtr->mask & TCL_READABLE) { + XtRemoveInput(filePtr->read); + } + if (filePtr->mask & TCL_WRITABLE) { + XtRemoveInput(filePtr->write); + } + if (filePtr->mask & TCL_EXCEPTION) { + XtRemoveInput(filePtr->except); + } + ckfree((char *) filePtr); +} + +/* + *---------------------------------------------------------------------- + * + * FileProc -- + * + * These procedures are called by Xt when a file becomes readable, + * writable, or has an exception. + * + * Results: + * None. + * + * Side effects: + * Makes an entry on the Tcl event queue if the event is + * interesting. + * + *---------------------------------------------------------------------- + */ + +static void +FileProc(clientData, fd, id) + caddr_t clientData; + int *fd; + XtInputId *id; +{ + FileHandler *filePtr = (FileHandler *)clientData; + FileHandlerEvent *fileEvPtr; + int mask = 0; + + /* + * Determine which event happened. + */ + + if (*id == filePtr->read) { + mask = TCL_READABLE; + } else if (*id == filePtr->write) { + mask = TCL_WRITABLE; + } else if (*id == filePtr->except) { + mask = TCL_EXCEPTION; + } + + /* + * Ignore unwanted or duplicate events. + */ + + if (!(filePtr->mask & mask) || (filePtr->readyMask & mask)) { + return; + } + + /* + * This is an interesting event, so put it onto the event queue. + */ + + filePtr->readyMask |= mask; + fileEvPtr = (FileHandlerEvent *) ckalloc(sizeof(FileHandlerEvent)); + fileEvPtr->header.proc = FileHandlerEventProc; + fileEvPtr->fd = filePtr->fd; + Tcl_QueueEvent((Tcl_Event *) fileEvPtr, TCL_QUEUE_TAIL); + + /* + * Process events on the Tcl event queue before returning to Xt. + */ + + Tcl_ServiceAll(); +} + +/* + *---------------------------------------------------------------------- + * + * FileHandlerEventProc -- + * + * This procedure is called by Tcl_ServiceEvent when a file event + * reaches the front of the event queue. This procedure is + * responsible for actually handling the event by invoking the + * callback for the file handler. + * + * Results: + * Returns 1 if the event was handled, meaning it should be removed + * from the queue. Returns 0 if the event was not handled, meaning + * it should stay on the queue. The only time the event isn't + * handled is if the TCL_FILE_EVENTS flag bit isn't set. + * + * Side effects: + * Whatever the file handler's callback procedure does. + * + *---------------------------------------------------------------------- + */ + +static int +FileHandlerEventProc(evPtr, flags) + Tcl_Event *evPtr; /* Event to service. */ + int flags; /* Flags that indicate what events to + * handle, such as TCL_FILE_EVENTS. */ +{ + FileHandler *filePtr; + FileHandlerEvent *fileEvPtr = (FileHandlerEvent *) evPtr; + int mask; + + if (!(flags & TCL_FILE_EVENTS)) { + return 0; + } + + /* + * Search through the file handlers to find the one whose handle matches + * the event. We do this rather than keeping a pointer to the file + * handler directly in the event, so that the handler can be deleted + * while the event is queued without leaving a dangling pointer. + */ + + for (filePtr = notifier.firstFileHandlerPtr; filePtr != NULL; + filePtr = filePtr->nextPtr) { + if (filePtr->fd != fileEvPtr->fd) { + continue; + } + + /* + * The code is tricky for two reasons: + * 1. The file handler's desired events could have changed + * since the time when the event was queued, so AND the + * ready mask with the desired mask. + * 2. The file could have been closed and re-opened since + * the time when the event was queued. This is why the + * ready mask is stored in the file handler rather than + * the queued event: it will be zeroed when a new + * file handler is created for the newly opened file. + */ + + mask = filePtr->readyMask & filePtr->mask; + filePtr->readyMask = 0; + if (mask != 0) { + (*filePtr->proc)(filePtr->clientData, mask); + } + break; + } + return 1; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_WaitForEvent -- + * + * This function is called by Tcl_DoOneEvent to wait for new + * events on the message queue. If the block time is 0, then + * Tcl_WaitForEvent just polls without blocking. + * + * Results: + * Returns 1 if an event was found, else 0. This ensures that + * Tcl_DoOneEvent will return 1, even if the event is handled + * by non-Tcl code. + * + * Side effects: + * Queues file events that are detected by the select. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_WaitForEvent( + Tcl_Time *timePtr) /* Maximum block time, or NULL. */ +{ + int timeout; + + if (!initialized) { + InitNotifier(); + } + + TclSetAppContext(NULL); + + if (timePtr) { + timeout = timePtr->sec * 1000 + timePtr->usec / 1000; + if (timeout == 0) { + if (XtAppPending(notifier.appContext)) { + goto process; + } else { + return 0; + } + } else { + Tcl_SetTimer(timePtr); + } + } +process: + XtAppProcessEvent(notifier.appContext, XtIMAll); + return 1; +} diff --git a/win/README.binary b/win/README.binary index ab1a51a..38b185f 100644 --- a/win/README.binary +++ b/win/README.binary @@ -1,6 +1,6 @@ Tcl/Tk 8.1b1 for Windows, Binary Distribution -RCS: @(#) $Id: README.binary,v 1.2.2.3 1998/12/11 19:33:59 stanton Exp $ +RCS: @(#) $Id: README.binary,v 1.2.2.4 1999/02/10 23:31:27 stanton Exp $ 1. Introduction --------------- @@ -91,31 +91,29 @@ See Encoding.3 for procedures that create new encodings and translate between encodings. See ToUpper.3 for procedures that perform case conversions on UTF-8 strings. -Binary data. Binary data is handled differently in -Tcl 8.1 than in Tcl 8.0. Tcl 8.1 uses the UTF-8 facilities to represent -binary data: the character value zero is represented with a multi-byte -sequence, so that (once again) strings in Tcl 8.1 never contain null bytes. -This means that binary data is now accepted everywhere in Tcl and Tk (in -Tcl 8.0 the support for binary data was incomplete). -If you have C code that needs to manipulate the bytes of binary data (as -opposed to just passing the data through) you should use a new object -type called "byte array". See the manual entry ByteArrObj.3 -for information about procedures such as -Tcl_GetByteArrayFromObj. -New regular expressions. Tcl 8.1 contains a brand new -implementation of regular expressions from Henry Spencer. This new version -supports almost all of the Perl extensions and it also handles UTF-8 and -binary data. -Multi-Threading. -Tcl 8.1 is multi-thread safe. -Each thread can contain several Tcl interpreters, but a given interpreter -can not be accessed from more than one thread. -Each thread runs its own event loop, and you can post events -to other threads. There is not yet support for tcl level use of threading -except for a test command. (Compile tcltest and try testthread.) -Tk 8.1 is not yet -multi-thread safe, and may never be due to limitations -of Xlib. +Binary data. Binary data is handled differently in Tcl 8.1 than in +Tcl 8.0. Tcl 8.1 uses the UTF-8 facilities to represent binary data: +the character value zero is represented with a multi-byte sequence, so +that (once again) strings in Tcl 8.1 never contain null bytes. This +means that binary data is now accepted everywhere in Tcl and Tk (in +Tcl 8.0 the support for binary data was incomplete). If you have C +code that needs to manipulate the bytes of binary data (as opposed to +just passing the data through) you should use a new object type called +"byte array". See the manual entry ByteArrObj.3 for information about +procedures such as Tcl_GetByteArrayFromObj. + +New regular expressions. Tcl 8.1 contains a brand new implementation +of regular expressions from Henry Spencer. This new version supports +almost all of the Perl extensions and it also handles UTF-8 and binary +data. + +Multi-Threading. Tcl 8.1 is multi-thread safe. Each thread can +contain several Tcl interpreters, but a given interpreter can not be +accessed from more than one thread. Each thread runs its own event +loop, and you can post events to other threads. There is not yet +support for tcl level use of threading except for a test +command. (Compile tcltest and try testthread.) Tk 8.1 is not yet +multi-thread safe, and may never be due to limitations of Xlib. What's new in Tk 8.1 @@ -141,18 +139,14 @@ It is implemented using DDE and there is a new dde command that allows Tk applications to use DDE to communicate with other Windows applications. send still doesn't work on the Macintosh. -3. Embedding. Application embedding now works on the Macintosh, as -long as both the container and embedded application are in the same -process. - -4. Configuration options. There is a new library of C procedures for +3. Configuration options. There is a new library of C procedures for manipulating widget configuration options using Tcl_Objs instead of strings. This should eventually make Tk much more efficient. Label, button, checkbutton, radiobutton, and menu widgets have been modified to use the new library. See SetOptions.3 for information on the new C APIs. -5. More Tcl_Obj support. Several additional C library procedures have +4. More Tcl_Obj support. Several additional C library procedures have been added to support Tcl_Objs. See the manual entries 3DBorder.3, GetAnchor.3, GetBitmap.3, GetColor.3, GetCursor.3, GetFont.3, GetJustify.3, and GetPixels.3. @@ -211,15 +205,6 @@ syntax changes in order to support all the new features: When greedy and non-greedy quantifiers are mixed, it's complicated and difficult to explain. -- The procedure Tcl_EvalObj has a new argument flags, and the - procedure Tcl_GlobalEvalObj has been removed (Tcl_EvalObj now - provides all of its functionality). - -- The procedures Tcl_ObjSetVar2 and Tcl_ObjGetVar2 have been renamed - Tcl_SetObjVar2 and Tcl_GetObjVar2 for consistency with other C APIs; - the name arguments have been changed from objects to strings. - - Known Problems With These Releases Both the internationalization support and the new regular expression diff --git a/win/makefile.vc b/win/makefile.vc index 7327475..86dc1c7 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -4,7 +4,9 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # Copyright (c) 1995-1996 Sun Microsystems, Inc. -# RCS: @(#) $Id: makefile.vc,v 1.1.2.13 1999/01/29 00:20:49 stanton Exp $ +# Copyright (c) 1998-1999 by Scriptics Corporation. +# +# RCS: @(#) $Id: makefile.vc,v 1.1.2.14 1999/02/10 23:31:28 stanton Exp $ # Does not depend on the presence of any environment variables in # order to compile tcl; all needed information is derived from @@ -13,9 +15,7 @@ # # Project directories # -# ROOT = top of source tree -# -# TMPDIR = location where .obj files should be stored during build +# ROOT = top of source tree # # TOOLS32 = location of VC++ 32-bit development tools. Note that the # VC++ 2.0 header files are broken, so you need to use the @@ -27,7 +27,7 @@ # is not available, then the 16-bit code will not be built. # Tcl will still run without the 16-bit code, but... # A. Under Windows 3.X any calls to the exec command -# will return an error. +# will return an error. # B. A 16-bit program to test the behavior of the exec # command under NT and 95 will not be built. # INSTALLDIR = where the install- targets should copy the binaries and @@ -35,11 +35,11 @@ # ROOT = .. -TOOLS32 = c:\progra~1\devstudio\vc -TOOLS32_rc = c:\progra~1\devstudio\sharedide +TOOLS32 = c:\program files\devstudio\vc +TOOLS32_rc = c:\program files\devstudio\sharedide TOOLS16 = c:\msvc -INSTALLDIR = c:\progra~1\Tcl +INSTALLDIR = c:\program files\Tcl # Set this to the appropriate value of /MACHINE: for your platform MACHINE = IX86 @@ -191,17 +191,17 @@ TCLOBJS = \ $(TMPDIR)\tclWinThrd.obj \ $(TMPDIR)\tclWinTime.obj -cc32 = $(TOOLS32)\bin\cl.exe -link32 = $(TOOLS32)\bin\link.exe -rc32 = $(TOOLS32_rc)\bin\rc.exe -include32 = -I$(TOOLS32)\include +cc32 = "$(TOOLS32)\bin\cl.exe" +link32 = "$(TOOLS32)\bin\link.exe" +rc32 = "$(TOOLS32_rc)\bin\rc.exe" +include32 = -I"$(TOOLS32)\include" -cc16 = $(TOOLS16)\bin\cl.exe -link16 = $(TOOLS16)\bin\link.exe -rc16 = $(TOOLS16)\bin\rc.exe -include16 = -I$(TOOLS16)\include +cc16 = "$(TOOLS16)\bin\cl.exe" +link16 = "$(TOOLS16)\bin\link.exe" +rc16 = "$(TOOLS16)\bin\rc.exe" +include16 = -I"$(TOOLS16)\include" -WINDIR = $(ROOT)\win +WINDIR = $(ROOT)\win GENERICDIR = $(ROOT)\generic TCL_INCLUDES = -I$(WINDIR) -I$(GENERICDIR) @@ -229,9 +229,9 @@ lcommon = /NODEFAULTLIB /RELEASE /NOLOGO # declarations for use on Intel i386, i486, and Pentium systems !IF "$(MACHINE)" == "IX86" DLLENTRY = @12 -lflags = $(lcommon) /MACHINE:$(MACHINE) +lflags = $(lcommon) /MACHINE:$(MACHINE) !ELSE -lflags = $(lcommon) /MACHINE:$(MACHINE) +lflags = $(lcommon) /MACHINE:$(MACHINE) !ENDIF conlflags = $(lflags) -subsystem:console -entry:mainCRTStartup @@ -247,7 +247,7 @@ libcdll = msvcrt$(DBGX).lib oldnames.lib !ENDIF baselibs = kernel32.lib $(optlibs) advapi32.lib user32.lib -winlibs = $(baselibs) gdi32.lib comdlg32.lib winspool.lib +winlibs = $(baselibs) gdi32.lib comdlg32.lib winspool.lib guilibs = $(libc) $(winlibs) conlibs = $(libc) $(baselibs) @@ -259,14 +259,8 @@ conlibsdll = $(libcdll) $(baselibs) ###################################################################### !IF "$(NODEBUG)" == "1" -!IF "$(MACHINE)" == "ALPHA" -# MSVC on Alpha doesn't understand -Ot -cdebug = -O2i -Gs -GD -!ELSE -#cdebug = -Oti -Gs -GD # This cranks the optimization level to maximize speed cdebug = -O2 -Gs -GD -!ENDIF !ELSE cdebug = -Z7 -Od -WX !ENDIF @@ -290,8 +284,8 @@ cflags = $(ccommon) -D_ALPHA_=1 !ENDIF !ENDIF -cvars = -DWIN32 -D_WIN32 -cvarsmt = $(cvars) -D_MT +cvars = -DWIN32 -D_WIN32 +cvarsmt = $(cvars) -D_MT cvarsdll = $(cvarsmt) -D_DLL !IF "$(NODEBUG)" == "1" @@ -313,7 +307,8 @@ install: install-binaries install-libraries test: setup $(TCLTEST) dlls $(CAT16) $(CAT32) copy $(WINDIR)\pkgIndex.tcl $(OUTDIR) set TCL_LIBRARY=$(ROOT)/library - $(TCLTEST) << + $(TCLTEST) << "$(TCLREGDLL)" + load [lindex $$argv 0] registry cd ../tests source all << @@ -324,14 +319,14 @@ setup: $(DUMPEXTS): $(WINDIR)\winDumpExts.c $(cc32) $(CON_CFLAGS) -Fo$(TMPDIR)\ $? - set LIB=$(TOOLS32)\lib + set LIB="$(TOOLS32)\lib" $(link32) $(ldebug) $(conlflags) $(guilibs) -out:$@ \ $(TMPDIR)\winDumpExts.obj $(TCLLIB): $(TCLDLL) $(TCLDLL): $(TCLOBJS) $(TMPDIR)\tcl.def $(TMPDIR)\tcl.res - set LIB=$(TOOLS32)\lib + set LIB="$(TOOLS32)\lib" $(link32) $(ldebug) $(dlllflags) -def:$(TMPDIR)\tcl.def \ -out:$@ $(TMPDIR)\tcl.res $(guilibsdll) @<< $(TCLOBJS) @@ -340,14 +335,14 @@ $(TCLOBJS) $(TCLPLUGINLIB): $(TCLPLUGINDLL) $(TCLPLUGINDLL): $(TCLOBJS) $(TMPDIR)\plugin.def $(TMPDIR)\tcl.res - set LIB=$(TOOLS32)\lib + set LIB="$(TOOLS32)\lib" $(link32) $(ldebug) $(dlllflags) -def:$(TMPDIR)\plugin.def \ -out:$@ $(TMPDIR)\tcl.res $(guilibsdll) @<< $(TCLOBJS) << $(TCLSH): $(TCLSHOBJS) $(TCLLIB) $(TMPDIR)\tclsh.res - set LIB=$(TOOLS32)\lib + set LIB="$(TOOLS32)\lib" $(link32) $(ldebug) $(conlflags) $(TMPDIR)\tclsh.res -stack:2300000 \ -out:$@ $(conlibsdll) $(TCLLIB) $(TCLSHOBJS) @@ -357,14 +352,14 @@ $(TCLSHP): $(TCLSHOBJS) $(TCLPLUGINLIB) $(TMPDIR)\tclsh.res -out:$@ $(conlibsdll) $(TCLPLUGINLIB) $(TCLSHOBJS) $(TCLTEST): $(TCLTESTOBJS) $(TCLLIB) $(TMPDIR)\tclsh.res - set LIB=$(TOOLS32)\lib + set LIB="$(TOOLS32)\lib" $(link32) $(ldebug) $(conlflags) $(TMPDIR)\tclsh.res -stack:2300000 \ -out:$@ $(conlibsdll) $(TCLLIB) $(TCLTESTOBJS) $(TCL16DLL): $(WINDIR)\tcl16.rc $(WINDIR)\tclWin16.c if exist $(cc16) $(cc16) @<< $(DLL16_CFLAGS) -Fo$(TMPDIR)\ $(WINDIR)\tclWin16.c -<< +<< @copy << $(TMPDIR)\tclWin16.def > nul LIBRARY $(@B);dll EXETYPE WINDOWS @@ -386,17 +381,17 @@ $(TMPDIR)\tclWin16.def $(TCLPIPEDLL): $(WINDIR)\stub16.c $(cc32) $(CON_CFLAGS) -Fo$(TMPDIR)\ $(WINDIR)\stub16.c - set LIB=$(TOOLS32)\lib + set LIB="$(TOOLS32)\lib" $(link32) $(ldebug) $(conlflags) -out:$@ $(TMPDIR)\stub16.obj $(guilibs) $(TCLREGDLL): $(TMPDIR)\tclWinReg.obj - set LIB=$(TOOLS32)\lib + set LIB="$(TOOLS32)\lib" $(link32) $(ldebug) $(dlllflags) -out:$@ $(TMPDIR)\tclWinReg.obj \ $(conlibsdll) $(TCLLIB) $(CAT32): $(WINDIR)\cat.c $(cc32) $(CON_CFLAGS) -Fo$(TMPDIR)\ $? - set LIB=$(TOOLS32)\lib + set LIB="$(TOOLS32)\lib" $(link32) $(conlflags) -out:$@ -stack:16384 $(TMPDIR)\cat.obj $(conlibs) $(CAT16): $(WINDIR)\cat.c @@ -420,14 +415,22 @@ install-binaries: $(TCLSH) @mkd $(LIB_INSTALL_DIR) @echo installing $(TCLDLLNAME) @copy $(TCLDLL) $(BIN_INSTALL_DIR) + @copy $(TCLLIB) $(LIB_INSTALL_DIR) @echo installing $(TCLSH) @copy $(TCLSH) $(BIN_INSTALL_DIR) + @echo installing $(TCLPIPEDLLNAME) + @copy $(TCLPIPEDLL) $(BIN_INSTALL_DIR) + @echo installing $(TCLREGDLLNAME) + @copy $(TCLREGDLL) $(LIB_INSTALL_DIR) install-libraries: -@mkd $(LIB_INSTALL_DIR) -@mkd $(INCLUDE_INSTALL_DIR) -@mkd $(SCRIPT_INSTALL_DIR) -@mkd $(SCRIPT_INSTALL_DIR)\http1.0 + @copy << "$(SCRIPT_INSTALL_DIR)\pkgIndex.tcl" +package ifneeded registry 1.0 "load [list [file join $$dir .. $(TCLREGDLLNAME)]] registry" +<< -@copy $(ROOT)\library\http1.0\http.tcl $(SCRIPT_INSTALL_DIR)\http1.0 -@copy $(ROOT)\library\http1.0\pkgIndex.tcl $(SCRIPT_INSTALL_DIR)\http1.0 -@mkd $(SCRIPT_INSTALL_DIR)\http2.0 @@ -455,8 +458,7 @@ $(TMPDIR)\tclWinInit.obj: $(WINDIR)\tclWinInit.c -Fo$(TMPDIR)\ $? $(TMPDIR)\testMain.obj: $(WINDIR)\tclAppInit.c - $(cc32) $(TCL_CFLAGS) -DSTATIC_BUILD -DTCL_TEST \ - -Fo$(TMPDIR)\testMain.obj $? + $(cc32) $(TCL_CFLAGS)-DTCL_TEST -Fo$(TMPDIR)\testMain.obj $? $(TMPDIR)\tclTest.obj: $(GENERICDIR)\tclTest.c $(cc32) $(TCL_CFLAGS) -Fo$@ $? @@ -468,7 +470,7 @@ $(TMPDIR)\tclWinTest.obj: $(WINDIR)\tclWinTest.c $(cc32) $(TCL_CFLAGS) -Fo$@ $? $(TMPDIR)\tclAppInit.obj : $(WINDIR)\tclAppInit.c - $(cc32) $(TCL_CFLAGS) -DSTATIC_BUILD -Fo$@ $? + $(cc32) $(TCL_CFLAGS) -Fo$@ $? # Dedependency rules @@ -509,15 +511,15 @@ $(GENERICDIR)\regguts.h: $(GENERICDIR)\regcustom.h $(TCL_DEFINES) $< clean: - -@del $(OUTDIR)\*.exp + -@del $(OUTDIR)\*.exp -@del $(OUTDIR)\*.lib -@del $(OUTDIR)\*.dll -@del $(OUTDIR)\*.exe -@del $(OUTDIR)\*.pdb -@del $(TMPDIR)\*.pch - -@del $(TMPDIR)\*.obj - -@del $(TMPDIR)\*.res - -@del $(TMPDIR)\*.def - -@del $(TMPDIR)\*.exe + -@del $(TMPDIR)\*.obj + -@del $(TMPDIR)\*.res + -@del $(TMPDIR)\*.def + -@del $(TMPDIR)\*.exe -@rmd $(OUTDIR) -@rmd $(TMPDIR) diff --git a/win/tclAppInit.c b/win/tclAppInit.c index c648b20..236001a 100644 --- a/win/tclAppInit.c +++ b/win/tclAppInit.c @@ -6,11 +6,12 @@ * program must be built in Win32 console mode to work properly. * * Copyright (c) 1996-1997 by Sun Microsystems, Inc. + * Copyright (c) 1998-1999 by Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclAppInit.c,v 1.1.2.3 1998/10/06 02:59:07 stanton Exp $ + * RCS: @(#) $Id: tclAppInit.c,v 1.1.2.4 1999/02/10 23:31:28 stanton Exp $ */ #include "tcl.h" @@ -18,12 +19,12 @@ #include <locale.h> #ifdef TCL_TEST -EXTERN int Procbodytest_Init _ANSI_ARGS_((Tcl_Interp *interp)); -EXTERN int Procbodytest_SafeInit _ANSI_ARGS_((Tcl_Interp *interp)); -EXTERN int Tcltest_Init _ANSI_ARGS_((Tcl_Interp *interp)); -EXTERN int TclObjTest_Init _ANSI_ARGS_((Tcl_Interp *interp)); +extern int Procbodytest_Init _ANSI_ARGS_((Tcl_Interp *interp)); +extern int Procbodytest_SafeInit _ANSI_ARGS_((Tcl_Interp *interp)); +extern int Tcltest_Init _ANSI_ARGS_((Tcl_Interp *interp)); +extern int TclObjTest_Init _ANSI_ARGS_((Tcl_Interp *interp)); #ifdef TCL_THREADS -EXTERN int TclThread_Init _ANSI_ARGS_((Tcl_Interp *interp)); +extern int TclThread_Init _ANSI_ARGS_((Tcl_Interp *interp)); #endif #endif /* TCL_TEST */ diff --git a/win/tclWinInit.c b/win/tclWinInit.c index 0a4c73b..64bcc58 100644 --- a/win/tclWinInit.c +++ b/win/tclWinInit.c @@ -4,11 +4,12 @@ * Contains the Windows-specific interpreter initialization functions. * * Copyright (c) 1994-1997 Sun Microsystems, Inc. + * Copyright (c) 1998-1999 by Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclWinInit.c,v 1.1.2.4 1998/11/11 04:08:39 stanton Exp $ + * RCS: @(#) $Id: tclWinInit.c,v 1.1.2.5 1999/02/10 23:31:28 stanton Exp $ */ #include "tclWinInt.h" @@ -525,7 +526,7 @@ TclpSetVariables(interp) */ Tcl_SetVar2(interp, "tcl_platform", "debug", "1", - TCL_GLOBAL_ONLY); + TCL_GLOBAL_ONLY); #endif /* @@ -585,7 +586,7 @@ Tcl_Init(interp) if (pathPtr == NULL) { pathPtr = Tcl_NewObj(); } - Tcl_SetObjVar2(interp, "tcl_libPath", NULL, pathPtr, TCL_GLOBAL_ONLY); + Tcl_SetVar2Ex(interp, "tcl_libPath", NULL, pathPtr, TCL_GLOBAL_ONLY); return Tcl_Eval(interp, initScript); } diff --git a/win/tclWinReg.c b/win/tclWinReg.c index 2fae2b2..9c487b2 100644 --- a/win/tclWinReg.c +++ b/win/tclWinReg.c @@ -6,11 +6,12 @@ * loadable extension in a separate DLL. * * Copyright (c) 1997 by Sun Microsystems, Inc. + * Copyright (c) 1998-1999 by Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclWinReg.c,v 1.1.2.2 1998/09/24 23:59:53 stanton Exp $ + * RCS: @(#) $Id: tclWinReg.c,v 1.1.2.3 1999/02/10 23:31:28 stanton Exp $ */ #include <tcl.h> @@ -61,7 +62,8 @@ static char *rootKeyNames[] = { "HKEY_LOCAL_MACHINE", "HKEY_USERS", "HKEY_CLASSES_ROOT", - "HKEY_CURRENT_USER", "HKEY_CURRENT_CONFIG", NULL + "HKEY_CURRENT_USER", "HKEY_CURRENT_CONFIG", + "HKEY_PERFORMANCE_DATA", "HKEY_DYN_DATA", NULL }; static HKEY rootKeys[] = { diff --git a/win/tclWinSock.c b/win/tclWinSock.c index 303dcb2..9a205a3 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclWinSock.c,v 1.1.2.4 1998/12/12 01:37:06 lfb Exp $ + * RCS: @(#) $Id: tclWinSock.c,v 1.1.2.5 1999/02/10 23:31:29 stanton Exp $ */ #include "tclWinInt.h" @@ -781,7 +781,7 @@ SocketEventProc(evPtr, flags) infoPtr->readyEvents &= ~(FD_READ); } } - if (events & FD_WRITE) { + if (events & (FD_WRITE | FD_CONNECT)) { mask |= TCL_WRITABLE; } @@ -1829,6 +1829,24 @@ TcpGetOptionProc(instanceData, interp, optionName, dsPtr) len = strlen(optionName); } + if ((len > 1) && (optionName[1] == 'e') && + (strncmp(optionName, "-error", len) == 0)) { + int optlen; + int err, ret; + + optlen = sizeof(int); + ret = TclWinGetSockOpt(sock, SOL_SOCKET, SO_ERROR, + (char *)&err, &optlen); + if (ret == SOCKET_ERROR) { + err = (*winSock.WSAGetLastError)(); + } + if (err) { + TclWinConvertWSAError(err); + Tcl_DStringAppend(dsPtr, Tcl_ErrnoMsg(Tcl_GetErrno()), -1); + } + return TCL_OK; + } + if ((len == 0) || ((len > 1) && (optionName[1] == 'p') && (strncmp(optionName, "-peername", len) == 0))) { @@ -1956,7 +1974,7 @@ TcpWatchProc(instanceData, mask) infoPtr->watchEvents |= (FD_READ|FD_CLOSE|FD_ACCEPT); } if (mask & TCL_WRITABLE) { - infoPtr->watchEvents |= (FD_WRITE); + infoPtr->watchEvents |= (FD_WRITE|FD_CONNECT); } /* diff --git a/win/winDumpExts.c b/win/winDumpExts.c index 36b03c3..cbf5eeb 100644 --- a/win/winDumpExts.c +++ b/win/winDumpExts.c @@ -19,7 +19,7 @@ * compiler other than Visual C++. *---------------------------------------------------------------------- * - * RCS: @(#) $Id: winDumpExts.c,v 1.1.2.1 1998/09/24 23:59:54 stanton Exp $ + * RCS: @(#) $Id: winDumpExts.c,v 1.1.2.2 1999/02/10 23:31:29 stanton Exp $ */ #include <windows.h> @@ -236,8 +236,14 @@ DumpExternals(PIMAGE_SYMBOL pSymbolTable, FILE *fout, unsigned cSymbols) strcpy(symbol, s); } s = symbol; - f = strchr(s, '@'); - if (f) { + + /* + * Skip to the last @ and ensure it is followed by digits, + * otherwise it is probably part of a C++ mangled name. + */ + + f = strrchr(s, '@'); + if (f && f[1] >= '0' && f[1] <= '9') { *f = 0; } #if defined(_MSC_VER) && defined(_X86_) @@ -468,10 +474,6 @@ main(int argc, char **argv) if (arg == argc) { goto Usage; } - fprintf(fout, "LIBRARY %s\n", dllname); - fprintf(fout, "EXETYPE WINDOWS\n"); - fprintf(fout, "CODE PRELOAD MOVEABLE DISCARDABLE\n"); - fprintf(fout, "DATA PRELOAD MOVEABLE MULTIPLE\n\n"); fprintf(fout, "EXPORTS\n"); } |