diff options
35 files changed, 836 insertions, 248 deletions
diff --git a/doc/OpenFileChnl.3 b/doc/OpenFileChnl.3 index 3a7b6ae..37ed2cd 100644 --- a/doc/OpenFileChnl.3 +++ b/doc/OpenFileChnl.3 @@ -406,8 +406,10 @@ to UTF-8 based on the channel's encoding and storing the produced data in \fIreadObjPtr\fR's string representation. The return value of \fBTcl_ReadChars\fR is the number of characters, up to \fIcharsToRead\fR, that were stored in \fIreadObjPtr\fR. If an error occurs while reading, the -return value is -1 and \fBTcl_ReadChars\fR records a POSIX error code that -can be retrieved with \fBTcl_GetErrno\fR. +return value is -1 and \fBTcl_ReadChars\fR records a POSIX error +code that can be retrieved with \fBTcl_GetErrno\fR. If an encoding error happens +while the channel is in blocking mode with -profile strict, the characters +retrieved until the encoding error happened will be stored in \fIreadObjPtr\fR. .PP Setting \fIcharsToRead\fR to -1 will cause the command to read all characters currently available (non-blocking) or everything until @@ -416,9 +418,9 @@ eof (blocking mode). The return value may be smaller than the value to read, indicating that less data than requested was available. This is called a \fIshort read\fR. In blocking mode, this can only happen on an end-of-file. In nonblocking mode, -a short read can also occur if there is not enough input currently -available: \fBTcl_ReadChars\fR returns a short count rather than waiting -for more data. +a short read can also occur if an encoding error is encountered (with -profile +strict) or if there is not enough input currently available: +\fBTcl_ReadChars\fR returns a short count rather than waiting for more data. .PP If the channel is in blocking mode, a return value of zero indicates an end-of-file condition. If the channel is in nonblocking mode, a return diff --git a/doc/TclZlib.3 b/doc/TclZlib.3 index 619b2dc..efbe07b 100644 --- a/doc/TclZlib.3 +++ b/doc/TclZlib.3 @@ -188,7 +188,7 @@ is used to initialize the compression engine rather than leaving it to create it on the fly from the data being compressed. Setting a compression dictionary allows for more efficient compression in the case where the start of the data is highly regular, but it does require both the compressor and the -decompressor to agreee on the value to use. Compression dictionaries are only +decompressor to agree on the value to use. Compression dictionaries are only fully supported for zlib-format data; on compression, they must be set before any data is sent in with \fBTcl_ZlibStreamPut\fR, and on decompression they should be set when \fBTcl_ZlibStreamGet\fR produces an \fBerror\fR with its diff --git a/doc/configurable.n b/doc/configurable.n index a138c33..0102f8c 100644 --- a/doc/configurable.n +++ b/doc/configurable.n @@ -14,7 +14,7 @@ oo::configurable, configure, property \- class that makes configurable classes a .nf package require TclOO -\fBoo::configurable create \fIclass\fR \fR?\fIdefinitionScript\fR? +\fBoo::configurable create \fIclass\fR ?\fIdefinitionScript\fR? \fBoo::define \fIclass\fB {\fR \fBproperty \fIpropName\fR ?\fIoptions...\fR? ?\fIpropName\fR ?\fIoptions...\fR?...? @@ -26,7 +26,7 @@ package require TclOO \fIobjectName \fBconfigure\fR \fIobjectName \fBconfigure\fR \fI\-prop\fR -\fIobjectName \fBconfigure\fR \fI\-prop value\fR ?\fI\-prop value\fR...\fR +\fIobjectName \fBconfigure\fR \fI\-prop value\fR ?\fI\-prop value\fR... .fi .SH "CLASS HIERARCHY" .nf @@ -146,7 +146,7 @@ so that they can be used by other code: .TP \fBoo::configuresupport::configurable\fR . -This is a class that provids the implementation of the \fBconfigure\fR method +This is a class that provides the implementation of the \fBconfigure\fR method (described above in \fBCONFIGURE METHOD\fR). .TP \fBoo::configuresupport::configurableclass\fR @@ -157,12 +157,11 @@ class constructors under normal circumstances), as described above in \fBPROPERTY DEFINITIONS\fR. It \fBnamespace export\fRs its \fBproperty\fR command so that it may be used easily in user definition dialects. .TP -. \fBoo::configuresupport::configurableobject\fR . This is a namespace that contains the definition dialect that provides the \fBproperty\fR declaration for use in instance objects (i.e., via -\fBoo::objdefine\fR, and the\fB self\R declaration in \fBoo::define), as +\fBoo::objdefine\fR, and the \fBself\fR declaration in \fBoo::define\fR), as described above in \fBPROPERTY DEFINITIONS\fR. It \fBnamespace export\fRs its \fBproperty\fR command so that it may be used easily in user definition dialects. diff --git a/doc/ledit.n b/doc/ledit.n index 70e0bf3..48bc608 100644 --- a/doc/ledit.n +++ b/doc/ledit.n @@ -24,7 +24,7 @@ Arguments \fIfirst\fR and \fIlast\fR are index values specifying the first and last elements of the range to replace. They are interpreted the same as index values for the command \fBstring index\fR, supporting simple index arithmetic and indices relative to the -end of the list. The index 0 refers to the first element of the +end of the list. The index \fB0\fR refers to the first element of the list, and \fBend\fR refers to the last element of the list. .PP If either \fIfirst\fR or \fIlast\fR is less than zero, it is considered to @@ -49,33 +49,33 @@ between \fIfirst\fR and \fIlast\fR are simply deleted. Prepend to a list. .PP .CS -% set lst {c d e f g} -c d e f g -% ledit lst -1 -1 a b -a b c d e f g +set lst {c d e f g} + \fI\(-> c d e f g\fR +\fBledit\fR lst -1 -1 a b + \fI\(-> a b c d e f g\fR .CE .PP Append to the list. .PP .CS -% ledit lst end+1 end+1 h i -a b c d e f g h i +\fBledit\fR lst end+1 end+1 h i + \fI\(-> a b c d e f g h i\fR .CE .PP Delete third and fourth elements. .PP .CS -% ledit lst 2 3 -a b e f g h i +\fBledit\fR lst 2 3 + \fI\(-> a b e f g h i\fR .CE .PP Replace two elements with three. .PP .CS -% ledit lst 2 3 x y z -a b x y z g h i -% set lst -a b x y z g h i +\fBledit\fR lst 2 3 x y z + \fI\(-> a b x y z g h i\fR +set lst + \fI\(-> a b x y z g h i\fR .CE .PP .SH "SEE ALSO" diff --git a/doc/library.n b/doc/library.n index 8aa8af7..64252f3 100644 --- a/doc/library.n +++ b/doc/library.n @@ -58,6 +58,7 @@ the auto-load mechanism defined below. The following procedures are provided in the Tcl library: .TP \fBauto_execok \fIcmd\fR +. Determines whether there is an executable file or shell builtin by the name \fIcmd\fR. If so, it returns a list of arguments to be passed to \fBexec\fR to execute the executable file or shell builtin @@ -70,8 +71,30 @@ remembers information about previous searches in an array named \fBauto_execs\fR; this avoids the path search in future calls for the same \fIcmd\fR. The command \fBauto_reset\fR may be used to force \fBauto_execok\fR to forget its cached information. +.RS +.PP +For example, to run the \fIumask\fR shell builtin on Linux, you would do: +.PP +.CS +exec {*}[\fBauto_execok\fR umask] +.CE +.PP +To run the \fIDIR\fR shell builtin on Windows, you would do: +.PP +.CS +exec {*}[\fBauto_execok\fR dir] +.CE +.PP +To discover if there is a \fIfrobnicate\fR binary on the user's PATH, +you would do: +.PP +.CS +set mayFrob [expr {[llength [\fBauto_execok\fR frobnicate]] > 0}] +.CE +.RE .TP \fBauto_import \fIpattern\fR +. \fBAuto_import\fR is invoked during \fBnamespace import\fR to see if the imported commands specified by \fIpattern\fR reside in an autoloaded library. If so, the commands are loaded so that they will @@ -79,13 +102,18 @@ be available to the interpreter for creating the import links. If the commands do not reside in an autoloaded library, \fBauto_import\fR does nothing. The pattern matching is performed according to the matching rules of \fBnamespace import\fR. +.RS +.PP +It is not normally necessary to call this command directly. +.RE .TP \fBauto_load \fIcmd\fR +. This command attempts to load the definition for a Tcl command named \fIcmd\fR. To do this, it searches an \fIauto-load path\fR, which is a list of one or more directories. The auto-load path is given by the global variable \fBauto_path\fR if it exists. If there is no -\fBauto_path\fR variable, then the TCLLIBPATH environment variable is +\fBauto_path\fR variable, then the \fBTCLLIBPATH\fR environment variable is used, if it exists. Otherwise the auto-load path consists of just the Tcl library directory. Within each directory in the auto-load path there must be a file \fBtclIndex\fR that describes one or more @@ -104,6 +132,11 @@ the array \fBauto_index\fR; future calls to \fBauto_load\fR check for cached index information may be deleted with the command \fBauto_reset\fR. This will force the next \fBauto_load\fR command to reload the index database from disk. +.RS +.PP +It is not normally necessary to call this command directly; the +default \fBunknown\fR handler will do so. +.RE .TP \fBauto_mkindex \fIdir pattern pattern ...\fR . @@ -156,6 +189,7 @@ listed in the auto-load index, so that fresh copies of them will be loaded the next time that they are used. .TP \fBauto_qualify \fIcommand namespace\fR +. Computes a list of fully qualified names for \fIcommand\fR. This list mirrors the path a standard Tcl interpreter follows for command lookups: first it looks for the command in the current namespace, and @@ -175,6 +209,7 @@ performing the actual auto-loading of functions at runtime. .RE .TP \fBtcl_findLibrary \fIbasename version patch initScript enVarName varName\fR +. This is a standard search procedure for use by extensions during their initialization. They call this procedure to look for their script library in several standard directories. @@ -197,14 +232,25 @@ relative to the executable file in the current build tree; relative to the executable file in a parallel build tree. .TP \fBparray \fIarrayName\fR ?\fIpattern\fR? +. Prints on standard output the names and values of all the elements in the array \fIarrayName\fR, or just the names that match \fIpattern\fR (using the matching rules of \fBstring match\fR) and their values if \fIpattern\fR is given. \fIArrayName\fR must be an array accessible to the caller of \fBparray\fR. It may be either local or global. +The result of this command is the empty string. +.RS +.PP +For example, to print the contents of the \fBtcl_platform\fR array, do: +.PP +.CS +\fBparray\fR tcl_platform +.CE +.RE .TP \fBtcl_endOfWord \fIstr start\fR +. Returns the index of the first end-of-word location that occurs after a starting index \fIstart\fR in the string \fIstr\fR. An end-of-word location is defined to be the first non-word character following the @@ -215,19 +261,35 @@ for more details on how Tcl determines which characters are word characters. .TP \fBtcl_startOfNextWord \fIstr start\fR +. Returns the index of the first start-of-word location that occurs after a starting index \fIstart\fR in the string \fIstr\fR. A start-of-word location is defined to be the first word character following a non-word character. Returns \-1 if there are no more start-of-word locations after the starting point. +.RS +.PP +For example, to print the indices of the starts of each word in a +string according to platform rules: +.PP +.CS +set theString "The quick brown fox" +for {set idx 0} {$idx >= 0} { + set idx [\fBtcl_startOfNextWord\fR $theString $idx]} { + puts "Word start index: $idx" +} +.CE +.RE .TP \fBtcl_startOfPreviousWord \fIstr start\fR +. Returns the index of the first start-of-word location that occurs before a starting index \fIstart\fR in the string \fIstr\fR. Returns \-1 if there are no more start-of-word locations before the starting point. .TP \fBtcl_wordBreakAfter \fIstr start\fR +. Returns the index of the first word boundary after the starting index \fIstart\fR in the string \fIstr\fR. Returns \-1 if there are no more boundaries after the starting point in the given string. The index @@ -235,6 +297,7 @@ returned refers to the second character of the pair that comprises a boundary. .TP \fBtcl_wordBreakBefore \fIstr start\fR +. Returns the index of the first word boundary before the starting index \fIstart\fR in the string \fIstr\fR. Returns \-1 if there are no more boundaries before the starting point in the given string. The index @@ -248,18 +311,30 @@ commands and packages, and determining what are words. .SS "AUTOLOADING AND PACKAGE MANAGEMENT VARIABLES" .TP \fBauto_execs\fR +. Used by \fBauto_execok\fR to record information about whether particular commands exist as executable files. +.RS +.PP +Not normally usefully accessed directly by user code. +.RE .TP \fBauto_index\fR +. Used by \fBauto_load\fR to save the index information read from disk. +.RS +.PP +Not normally usefully accessed directly by user code. +.RE .TP \fBauto_noexec\fR +. If set to any value, then \fBunknown\fR will not attempt to auto-exec any commands. .TP \fBauto_noload\fR +. If set to any value, then \fBunknown\fR will not attempt to auto-load any commands. .TP @@ -275,37 +350,70 @@ the parent directory of \fBtcl_library\fR, the directories listed in the \fBtcl_pkgPath\fR variable. Additional locations to look for files and package indices should normally be added to this variable using \fBlappend\fR. +.RS +.PP +For example, to add the \fIlib\fR directory next to the running +script, you would do: +.PP +.CS +lappend \fBauto_path\fR [file dirname [info script]]/lib +.CE +.PP +Note that if the script uses \fBcd\fR, it is advisable to ensure that +entries on the \fBauto_path\fR are \fBfile normalize\fRd. +.RE .TP \fBenv(TCL_LIBRARY)\fR +. If set, then it specifies the location of the directory containing library scripts (the value of this variable will be assigned to the \fBtcl_library\fR variable and therefore returned by the command \fBinfo library\fR). If this variable is not set then a default value is used. +.RS +.PP +Use of this environment variable is not recommended outside of testing. +Tcl installations should already know where to find their own script +files, as the value is baked in during the build or installation. +.RE .TP \fBenv(TCLLIBPATH)\fR +. If set, then it must contain a valid Tcl list giving directories to search during auto-load operations. Directories must be specified in Tcl format, using .QW / as the path separator, regardless of platform. This variable is only used when initializing the \fBauto_path\fR variable. +.RS +.PP +A key consequence of this variable is that it gives a way to let the user +of a script specify the list of places where that script may use +\fBpackage require\fR to read packages from. It is not normally usefully +settable within a Tcl script itself \fIexcept\fR to influence where other +interpreters load from (whether made with \fBinterp create\fR or launched +as their own threads or subprocesses). +.RE .SS "WORD BOUNDARY DETERMINATION VARIABLES" These variables are only used in the \fBtcl_endOfWord\fR, \fBtcl_startOfNextWord\fR, \fBtcl_startOfPreviousWord\fR, \fBtcl_wordBreakAfter\fR, and \fBtcl_wordBreakBefore\fR commands. .TP \fBtcl_nonwordchars\fR +. This variable contains a regular expression that is used by routines like \fBtcl_endOfWord\fR to identify whether a character is part of a word or not. If the pattern matches a character, the character is -considered to be a non-word character. The default is "\\W". +considered to be a non-word character. The default value is +.QW "\\W" . .TP \fBtcl_wordchars\fR +. This variable contains a regular expression that is used by routines like \fBtcl_endOfWord\fR to identify whether a character is part of a word or not. If the pattern matches a character, the character is -considered to be a word character. The default is "\\w". +considered to be a word character. The default value is +.QW "\\w" . .SH "SEE ALSO" env(n), info(n), re_syntax(n) .SH KEYWORDS @@ -128,6 +128,28 @@ If a new file is created as part of opening it, \fIpermissions\fR (an integer) is used to set the permissions for the new file in conjunction with the process's file mode creation mask. \fIPermissions\fR defaults to 0666. +.PP +.VS "8.7, TIP 603" +When the file opened is an ordinary disk file, the \fBchan configure\fR and +\fBfconfigure\fR commands can be used to query this additional configuration +option: +.TP +\fB\-stat\fR +. +This option, when read, returns a dictionary of values much as is obtained +from the \fBfile stat\fR command, where that stat information relates to the +real opened file. Keys in the dictionary may include \fBatime\fR, \fBctime\fR, +\fBdev\fR, \fBgid\fR, \fBino\fR, \fBmode\fR, \fBmtime\fR, \fBnlink\fR, +\fBsize\fR, \fBtype\fR, and \fBuid\fR among others; the \fBmtime\fR, +\fBsize\fR and \fBtype\fR fields are guaranteed to be present and meaningful +on all platforms; other keys may be present too. +.RS +.PP +\fIImplementation note:\fR This option maps to a call to \fBfstat()\fR on +POSIX platforms, and to a call to \fBGetFileInformationByHandle()\fR on +Windows; the information reported is what those system calls produce. +.RE +.VE "8.7, TIP 603" .SH "COMMAND PIPELINES" .PP If the first character of \fIfileName\fR is diff --git a/doc/timerate.n b/doc/timerate.n index c5fdf30..5d49c86 100644 --- a/doc/timerate.n +++ b/doc/timerate.n @@ -35,10 +35,10 @@ if \fItime\fR is not specified. .sp The parameter \fImax-count\fR could additionally impose a further restriction by the maximal number of iterations to evaluate the script. -If \fImax-count\fR is specified, the evalution will stop either this count of +If \fImax-count\fR is specified, the evaluation will stop either this count of iterations is reached or the time is exceeded. .sp -It will then return a canonical tcl-list of the form: +It will then return a canonical Tcl-list of the form: .PP .CS \fB0.095977 \(mcs/# 52095836 # 10419167 #/sec 5000.000 net-ms\fR @@ -85,7 +85,7 @@ used to measure the cost of \fBTcl_EvalObjEx\fR, of the invocation of canonical lists, and of the uncompiled versions of bytecoded commands. .PP As opposed to the \fBtime\fR commmand, which runs the tested script for a fixed -number of iterations, the timerate command runs it for a fixed time. +number of iterations, the \fBtimerate\fR command runs it for a fixed time. Additionally, the compiled variant of the script will be used during the entire measurement, as if the script were part of a compiled procedure, if the \fB\-direct\fR option is not specified. The fixed time period and possibility of compilation allow diff --git a/generic/tclArithSeries.c b/generic/tclArithSeries.c index 543e989..8304d7f 100755 --- a/generic/tclArithSeries.c +++ b/generic/tclArithSeries.c @@ -508,7 +508,7 @@ TclNewArithSeriesObj( dstep = step; } if (dstep == 0) { - *arithSeriesObj = Tcl_NewObj(); + TclNewObj(*arithSeriesObj); return TCL_OK; } } diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 22c4278..b412cd3 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -805,7 +805,7 @@ Tcl_CreateInterp(void) iPtr->legacyFreeProc = (void (*) (void))-1; iPtr->errorLine = 0; iPtr->stubTable = &tclStubs; - iPtr->objResultPtr = Tcl_NewObj(); + TclNewObj(iPtr->objResultPtr); Tcl_IncrRefCount(iPtr->objResultPtr); iPtr->handle = TclHandleCreate(iPtr); iPtr->globalNsPtr = NULL; @@ -890,7 +890,7 @@ Tcl_CreateInterp(void) iPtr->activeInterpTracePtr = NULL; iPtr->assocData = NULL; iPtr->execEnvPtr = NULL; /* Set after namespaces initialized. */ - iPtr->emptyObjPtr = Tcl_NewObj(); + TclNewObj(iPtr->emptyObjPtr); /* Another empty object. */ Tcl_IncrRefCount(iPtr->emptyObjPtr); iPtr->threadId = Tcl_GetCurrentThread(); @@ -954,7 +954,7 @@ Tcl_CreateInterp(void) * TIP #285, Script cancellation support. */ - iPtr->asyncCancelMsg = Tcl_NewObj(); + TclNewObj(iPtr->asyncCancelMsg); cancelInfo = (CancelInfo *)Tcl_Alloc(sizeof(CancelInfo)); cancelInfo->interp = interp; diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 7242881..a12c65b 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -2324,7 +2324,7 @@ StoreStatData( unsigned short mode; if (varName == NULL) { - result = Tcl_NewObj(); + TclNewObj(result); Tcl_IncrRefCount(result); #define DOBJPUT(key, objValue) \ Tcl_DictObjPut(NULL, result, \ @@ -2387,8 +2387,14 @@ StoreStatData( #ifdef HAVE_STRUCT_STAT_ST_BLKSIZE STORE_ARY("blksize", Tcl_NewWideIntObj((long)statPtr->st_blksize)); #endif +#ifdef HAVE_STRUCT_STAT_ST_RDEV + if (S_ISCHR(statPtr->st_mode) || S_ISBLK(statPtr->st_mode)) { + STORE_ARY("rdev", Tcl_NewWideIntObj((long) statPtr->st_rdev)); + } +#endif STORE_ARY("atime", Tcl_NewWideIntObj(Tcl_GetAccessTimeFromStat(statPtr))); - STORE_ARY("mtime", Tcl_NewWideIntObj(Tcl_GetModificationTimeFromStat(statPtr))); + STORE_ARY("mtime", Tcl_NewWideIntObj( + Tcl_GetModificationTimeFromStat(statPtr))); STORE_ARY("ctime", Tcl_NewWideIntObj(Tcl_GetChangeTimeFromStat(statPtr))); mode = (unsigned short) statPtr->st_mode; STORE_ARY("mode", Tcl_NewWideIntObj(mode)); diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index a29af82..b2f4502 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -711,7 +711,7 @@ InfoCommandsCmd( if (entryPtr != NULL) { if (specificNsInPattern) { cmd = (Tcl_Command)Tcl_GetHashValue(entryPtr); - elemObjPtr = Tcl_NewObj(); + TclNewObj(elemObjPtr); Tcl_GetCommandFullName(interp, cmd, elemObjPtr); } else { cmdName = (const char *)Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr); @@ -762,7 +762,7 @@ InfoCommandsCmd( || Tcl_StringMatch(cmdName, simplePattern)) { if (specificNsInPattern) { cmd = (Tcl_Command)Tcl_GetHashValue(entryPtr); - elemObjPtr = Tcl_NewObj(); + TclNewObj(elemObjPtr); Tcl_GetCommandFullName(interp, cmd, elemObjPtr); } else { elemObjPtr = Tcl_NewStringObj(cmdName, -1); @@ -989,7 +989,8 @@ InfoDefaultCmd( } Tcl_SetObjResult(interp, Tcl_NewWideIntObj(1)); } else { - Tcl_Obj *nullObjPtr = Tcl_NewObj(); + Tcl_Obj *nullObjPtr; + TclNewObj(nullObjPtr); valueObjPtr = Tcl_ObjSetVar2(interp, objv[3], NULL, nullObjPtr, TCL_LEAVE_ERR_MSG); @@ -1905,7 +1906,7 @@ InfoProcsCmd( } else { simpleProcOK: if (specificNsInPattern) { - elemObjPtr = Tcl_NewObj(); + TclNewObj(elemObjPtr); Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, elemObjPtr); } else { @@ -1933,7 +1934,7 @@ InfoProcsCmd( } else { procOK: if (specificNsInPattern) { - elemObjPtr = Tcl_NewObj(); + TclNewObj(elemObjPtr); Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, elemObjPtr); } else { @@ -2255,7 +2256,7 @@ Tcl_JoinObjCmd( } else { Tcl_Size i; - resObjPtr = Tcl_NewObj(); + TclNewObj(resObjPtr); for (i = 0; i < listLen; i++) { if (i > 0) { diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 9cdbcea..e6bda99 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -357,7 +357,7 @@ Tcl_RegexpObjCmd( objc = info.nsubs + 1; if (all <= 1) { - resultPtr = Tcl_NewObj(); + TclNewObj(resultPtr); } } for (i = 0; i < objc; i++) { @@ -399,7 +399,7 @@ Tcl_RegexpObjCmd( offset + info.matches[i].start, offset + info.matches[i].end - 1); } else { - newPtr = Tcl_NewObj(); + TclNewObj(newPtr); } } if (doinline) { @@ -1194,7 +1194,7 @@ Tcl_SplitObjCmd( stringPtr = Tcl_GetStringFromObj(objv[1], &stringLen); end = stringPtr + stringLen; - listPtr = Tcl_NewObj(); + TclNewObj(listPtr); if (stringLen == 0) { /* @@ -4701,7 +4701,7 @@ TclNRTryObjCmd( return TCL_ERROR; } bodyObj = objv[1]; - handlersObj = Tcl_NewObj(); + TclNewObj(handlersObj); bodyShared = 0; haveHandlers = 0; for (i=2 ; i<objc ; i++) { diff --git a/generic/tclIO.c b/generic/tclIO.c index 965a395..4d327b3 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -659,7 +659,7 @@ TclFinalizeIOSubsystem(void) statePtr->refCount--; } - if (statePtr->refCount + 1 <= 1) { + if (statePtr->refCount <= 0) { /* * Close it only if the refcount indicates that the channel is * not referenced from any interpreter. If it is, that @@ -1078,7 +1078,7 @@ CheckForStdChannelsBeingClosed( if (tsdPtr->stdinInitialized == 1 && tsdPtr->stdinChannel != NULL && statePtr == ((Channel *)tsdPtr->stdinChannel)->state) { - if (statePtr->refCount + 1 < 3) { + if (statePtr->refCount < 2) { statePtr->refCount = 0; tsdPtr->stdinChannel = NULL; return; @@ -1086,7 +1086,7 @@ CheckForStdChannelsBeingClosed( } else if (tsdPtr->stdoutInitialized == 1 && tsdPtr->stdoutChannel != NULL && statePtr == ((Channel *)tsdPtr->stdoutChannel)->state) { - if (statePtr->refCount + 1 < 3) { + if (statePtr->refCount < 2) { statePtr->refCount = 0; tsdPtr->stdoutChannel = NULL; return; @@ -1094,7 +1094,7 @@ CheckForStdChannelsBeingClosed( } else if (tsdPtr->stderrInitialized == 1 && tsdPtr->stderrChannel != NULL && statePtr == ((Channel *)tsdPtr->stderrChannel)->state) { - if (statePtr->refCount + 1 < 3) { + if (statePtr->refCount < 2) { statePtr->refCount = 0; tsdPtr->stderrChannel = NULL; return; @@ -1256,7 +1256,7 @@ Tcl_UnregisterChannel( * If the refCount reached zero, close the actual channel. */ - if (statePtr->refCount + 1 <= 1) { + if (statePtr->refCount <= 0) { Tcl_Preserve(statePtr); if (!GotFlag(statePtr, BG_FLUSH_SCHEDULED)) { /* @@ -1681,11 +1681,11 @@ Tcl_CreateChannel( statePtr->inputEncodingState = NULL; statePtr->inputEncodingFlags = TCL_ENCODING_START; ENCODING_PROFILE_SET(statePtr->inputEncodingFlags, - TCL_ENCODING_PROFILE_DEFAULT); + TCL_ENCODING_PROFILE_TCL8); statePtr->outputEncodingState = NULL; statePtr->outputEncodingFlags = TCL_ENCODING_START; ENCODING_PROFILE_SET(statePtr->outputEncodingFlags, - TCL_ENCODING_PROFILE_DEFAULT); + TCL_ENCODING_PROFILE_TCL8); /* * Set the channel up initially in AUTO input translation mode to accept @@ -2004,7 +2004,7 @@ static void ChannelFree( Channel *chanPtr) { - if (!chanPtr->refCount) { + if (chanPtr->refCount == 0) { Tcl_Free(chanPtr); return; } @@ -2179,7 +2179,7 @@ Tcl_UnstackChannel( * necessary. */ - if (statePtr->refCount + 1 <= 1) { + if (statePtr->refCount <= 0) { if (Tcl_CloseEx(interp, chan, 0) != TCL_OK) { /* * TIP #219, Tcl Channel Reflection API. @@ -2547,7 +2547,7 @@ static int IsShared( ChannelBuffer *bufPtr) { - return bufPtr->refCount + 1 > 2; + return bufPtr->refCount > 1; } /* @@ -2996,7 +2996,7 @@ FlushChannel( * current output buffer. */ - if (GotFlag(statePtr, CHANNEL_CLOSED) && (statePtr->refCount + 1 <= 1) && + if (GotFlag(statePtr, CHANNEL_CLOSED) && (statePtr->refCount <= 0) && (statePtr->outQueueHead == NULL) && ((statePtr->curOutPtr == NULL) || IsBufferEmpty(statePtr->curOutPtr))) { @@ -3457,7 +3457,7 @@ TclClose( statePtr = chanPtr->state; chanPtr = statePtr->topChanPtr; - if (statePtr->refCount + 1 > 1) { + if (statePtr->refCount > 0) { Tcl_Panic("called Tcl_Close on channel with refCount > 0"); } @@ -4192,7 +4192,6 @@ Tcl_WriteChars( } objPtr = Tcl_NewStringObj(src, len); - Tcl_IncrRefCount(objPtr); src = (char *) Tcl_GetByteArrayFromObj(objPtr, &len); if (src == NULL) { Tcl_SetErrno(EILSEQ); @@ -4366,8 +4365,8 @@ Write( while (srcLen + saved + endEncoding > 0 && !encodingError) { ChannelBuffer *bufPtr; char *dst; - int result, srcRead, dstLen, dstWrote; - Tcl_Size srcLimit = srcLen; + int result, srcRead, dstLen, dstWrote; + Tcl_Size srcLimit = srcLen; if (nextNewLine) { srcLimit = nextNewLine - src; @@ -4557,7 +4556,7 @@ Tcl_Gets( TclNewObj(objPtr); charsStored = Tcl_GetsObj(chan, objPtr); - if (charsStored + 1 > 1) { + if (charsStored > 0) { TclDStringAppendObj(lineRead, objPtr); } TclDecrRefCount(objPtr); @@ -5998,7 +5997,7 @@ DoReadChars( } ResetFlag(statePtr, CHANNEL_BLOCKED|CHANNEL_EOF); statePtr->inputEncodingFlags &= ~TCL_ENCODING_END; - for (copied = 0; toRead > 0 || toRead == TCL_INDEX_NONE; ) { + for (copied = 0; toRead != 0 ; ) { int copiedNow = -1; if (statePtr->inQueueHead != NULL) { if (binaryMode) { @@ -8217,7 +8216,7 @@ Tcl_SetChannelOption( if (interp) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "bad value for -eofchar: must be non-NUL ASCII" - " character", -1)); + " character", TCL_INDEX_NONE)); } Tcl_Free((void *)argv); return TCL_ERROR; @@ -10642,7 +10641,7 @@ Tcl_IsChannelShared( ChannelState *statePtr = ((Channel *) chan)->state; /* State of real channel structure. */ - return ((statePtr->refCount + 1 > 2) ? 1 : 0); + return ((statePtr->refCount > 1) ? 1 : 0); } /* diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index 93c50ec..37be141 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -1788,9 +1788,9 @@ ChanPendingObjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Channel chan; - int mode; static const char *const options[] = {"input", "output", NULL}; enum pendingOptionsEnum {PENDING_INPUT, PENDING_OUTPUT} index; + int mode; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "mode channelId"); diff --git a/generic/tclInt.h b/generic/tclInt.h index d052c0e..15b5029 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4564,7 +4564,7 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, /* *---------------------------------------------------------------- - * Macro used by the Tcl core to set a Tcl_Obj's string representation to a + * Macros used by the Tcl core to set a Tcl_Obj's string representation to a * copy of the "len" bytes starting at "bytePtr". The value of "len" must * not be negative. When "len" is 0, then it is acceptable to pass * "bytePtr" = NULL. When "len" > 0, "bytePtr" must not be NULL, and it @@ -4577,17 +4577,22 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, * Because "len" is referenced multiple times, take care that it is an * expression with the same value each use. * - * The ANSI C "prototype" for this macro is: + * The ANSI C "prototypes" for these macros are: * + * MODULE_SCOPE void TclInitEmptyStringRep(Tcl_Obj *objPtr); * MODULE_SCOPE void TclInitStringRep(Tcl_Obj *objPtr, char *bytePtr, size_t len); + * MODULE_SCOPE void TclAttemptInitStringRep(Tcl_Obj *objPtr, char *bytePtr, size_t len); * *---------------------------------------------------------------- */ +#define TclInitEmptyStringRep(objPtr) \ + ((objPtr)->length = (((objPtr)->bytes = &tclEmptyString), 0)) + + #define TclInitStringRep(objPtr, bytePtr, len) \ if ((len) == 0) { \ - (objPtr)->bytes = &tclEmptyString; \ - (objPtr)->length = 0; \ + TclInitEmptyStringRep(objPtr); \ } else { \ (objPtr)->bytes = (char *)Tcl_Alloc((len) + 1U); \ memcpy((objPtr)->bytes, (bytePtr) ? (bytePtr) : &tclEmptyString, (len)); \ @@ -4595,6 +4600,16 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, (objPtr)->length = (len); \ } +#define TclAttemptInitStringRep(objPtr, bytePtr, len) \ + ((((len) == 0) ? ( \ + TclInitEmptyStringRep(objPtr) \ + ) : ( \ + (objPtr)->bytes = (char *)Tcl_AttemptAlloc((len) + 1U), \ + (objPtr)->length = ((objPtr)->bytes) ? \ + (memcpy((objPtr)->bytes, (bytePtr) ? (bytePtr) : &tclEmptyString, (len)), \ + (objPtr)->bytes[len] = '\0', (len)) : (-1) \ + )), (objPtr)->bytes) + /* *---------------------------------------------------------------- * Macro used by the Tcl core to get the string representation's byte array diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c index 39fd020..7695483 100644 --- a/generic/tclOOCall.c +++ b/generic/tclOOCall.c @@ -2255,7 +2255,7 @@ TclOOGetAllClassProperties( *allocated = 1; Tcl_InitObjHashTable(&hashTable); FindClassProps(clsPtr, writable, &hashTable); - result = Tcl_NewObj(); + TclNewObj(result); FOREACH_HASH(propName, dummy, &hashTable) { Tcl_ListObjAppendElement(NULL, result, propName); } @@ -2337,7 +2337,7 @@ TclOOGetAllObjectProperties( *allocated = 1; Tcl_InitObjHashTable(&hashTable); FindObjectProps(oPtr, writable, &hashTable); - result = Tcl_NewObj(); + TclNewObj(result); FOREACH_HASH(propName, dummy, &hashTable) { Tcl_ListObjAppendElement(NULL, result, propName); } diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index a3bdddf..7a88ab7 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -3229,7 +3229,7 @@ ClassRPropsGet( return TCL_ERROR; } - resultObj = Tcl_NewObj(); + TclNewObj(resultObj); FOREACH(propNameObj, oPtr->classPtr->properties.readable) { Tcl_ListObjAppendElement(NULL, resultObj, propNameObj); } @@ -3294,7 +3294,7 @@ ObjRPropsGet( return TCL_ERROR; } - resultObj = Tcl_NewObj(); + TclNewObj(resultObj); FOREACH(propNameObj, oPtr->properties.readable) { Tcl_ListObjAppendElement(NULL, resultObj, propNameObj); } @@ -3426,7 +3426,7 @@ ClassWPropsGet( return TCL_ERROR; } - resultObj = Tcl_NewObj(); + TclNewObj(resultObj); FOREACH(propNameObj, oPtr->classPtr->properties.writable) { Tcl_ListObjAppendElement(NULL, resultObj, propNameObj); } @@ -3491,7 +3491,7 @@ ObjWPropsGet( return TCL_ERROR; } - resultObj = Tcl_NewObj(); + TclNewObj(resultObj); FOREACH(propNameObj, oPtr->properties.writable) { Tcl_ListObjAppendElement(NULL, resultObj, propNameObj); } diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c index ab17a35..e71cddc 100644 --- a/generic/tclOOInfo.c +++ b/generic/tclOOInfo.c @@ -1787,7 +1787,7 @@ InfoClassPropCmd( SortPropList(result); } } else { - result = Tcl_NewObj(); + TclNewObj(result); if (writable) { FOREACH(propObj, clsPtr->properties.writable) { Tcl_ListObjAppendElement(NULL, result, propObj); @@ -1850,7 +1850,7 @@ InfoObjectPropCmd( SortPropList(result); } } else { - result = Tcl_NewObj(); + TclNewObj(result); if (writable) { FOREACH(propObj, oPtr->properties.writable) { Tcl_ListObjAppendElement(NULL, result, propObj); diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h index 407e919..b7c1f1d 100644 --- a/generic/tclOOScript.h +++ b/generic/tclOOScript.h @@ -19,7 +19,7 @@ /* * The scripted part of the definitions of TclOO. * - * Compiled from generic/tclOOScript.tcl by tools/makeHeader.tcl, which + * Compiled from tools/tclOOScript.tcl by tools/makeHeader.tcl, which * contains the commented version of everything; *this* file is automatically * generated. */ diff --git a/generic/tclObj.c b/generic/tclObj.c index b8b572e..9ad45df 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -1000,7 +1000,7 @@ TclDbDumpActiveObjects( tablePtr = tsdPtr->objThreadMap; if (tablePtr != NULL) { - fprintf(outFile, "total objects: %" TCL_Z_MODIFIER "u\n", tablePtr->numEntries); + fprintf(outFile, "total objects: %" TCL_SIZE_MODIFIER "d\n", tablePtr->numEntries); for (hPtr = Tcl_FirstHashEntry(tablePtr, &hSearch); hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) { ObjData *objData = (ObjData *)Tcl_GetHashValue(hPtr); @@ -1054,7 +1054,7 @@ TclDbInitNewObj( { objPtr->refCount = 0; objPtr->typePtr = NULL; - TclInitStringRep(objPtr, NULL, 0); + TclInitEmptyStringRep(objPtr); #if TCL_THREADS /* @@ -1196,7 +1196,9 @@ Tcl_DbNewObj( TCL_UNUSED(const char *) /*file*/, TCL_UNUSED(int) /*line*/) { - return Tcl_NewObj(); + Tcl_Obj *objPtr; + TclNewObj(objPtr); + return objPtr; } #endif /* TCL_MEM_DEBUG */ @@ -1590,7 +1592,7 @@ Tcl_DuplicateObj( /* *---------------------------------------------------------------------- * - * Tcl_DuplicatePureObj -- + * TclDuplicatePureObj -- * * Duplicates a Tcl_Obj and converts the internal representation of the * duplicate to the given type, changing neither the 'bytes' field @@ -1659,7 +1661,14 @@ int SetDuplicatePureObj( || useTypePtr == &tclStringType ) ) { - TclInitStringRep(dupPtr, bytes, objPtr->length); + if (!TclAttemptInitStringRep(dupPtr, bytes, objPtr->length)) { + if (interp) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "insufficient memory to initialize string", -1)); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + } + status = TCL_ERROR; + } } return status; } @@ -1918,7 +1927,7 @@ Tcl_InitStringRep( if (objPtr->bytes == NULL) { /* Start with no string rep */ if (numBytes == 0) { - TclInitStringRep(objPtr, NULL, 0); + TclInitEmptyStringRep(objPtr); return objPtr->bytes; } else { objPtr->bytes = (char *)Tcl_AttemptAlloc(numBytes + 1); @@ -1945,7 +1954,7 @@ Tcl_InitStringRep( /* Start with non-empty string rep (allocated) */ if (numBytes == 0) { Tcl_Free(objPtr->bytes); - TclInitStringRep(objPtr, NULL, 0); + TclInitEmptyStringRep(objPtr); return objPtr->bytes; } else { objPtr->bytes = (char *)Tcl_AttemptRealloc(objPtr->bytes, @@ -2013,8 +2022,9 @@ Tcl_HasStringRep( * Called to set the object's internal representation to match a * particular type. * - * It is the caller's resonsibility to ensure that the given IntRep is - * appropriate for the existing string. + * It is the caller's responsibility to guarantee that + * the value of the submitted internalrep is in agreement with + * the value of any existing string rep. * * Results: * None. @@ -2030,16 +2040,14 @@ void Tcl_StoreInternalRep( Tcl_Obj *objPtr, /* Object whose internal rep should be set. */ const Tcl_ObjType *typePtr, /* New type for the object */ - const Tcl_ObjInternalRep *irPtr) /* New IntRep for the object */ + const Tcl_ObjInternalRep *irPtr) /* New internalrep for the object */ { - /* Clear out any existing IntRep. This is the point where shimmering, i.e. - * repeated alteration of the type of the internal representation, may - * occur. */ + /* Clear out any existing internalrep ( "shimmer" ) */ TclFreeInternalRep(objPtr); - /* When irPtr == NULL, just leave objPtr with no IntRep for typePtr */ + /* When irPtr == NULL, just leave objPtr with no internalrep for typePtr */ if (irPtr) { - /* Copy the new IntRep into place */ + /* Copy the new internalrep into place */ objPtr->internalRep = *irPtr; /* Set the type to match */ @@ -2275,8 +2283,8 @@ ParseBoolean( if ((length == 0) || (length > 5)) { /* - * Longest valid boolean string rep. is "false". - */ + * Longest valid boolean string rep. is "false". + */ return TCL_ERROR; } @@ -3514,7 +3522,7 @@ GetBignumFromObj( * bignum values are converted to empty string. */ if (objPtr->bytes == NULL) { - TclInitStringRep(objPtr, NULL, 0); + TclInitEmptyStringRep(objPtr); } } return TCL_OK; @@ -3878,7 +3886,7 @@ int Tcl_IsShared( Tcl_Obj *objPtr) /* The object to test for being shared. */ { - return ((objPtr)->refCount + 1 > 2); + return ((objPtr)->refCount > 1); } /* @@ -4321,7 +4329,7 @@ TclHashObjKey( * See [tcl-Feature Request #2958832] */ - if (length) { + if (length > 0) { result = UCHAR(*string); while (--length) { result += (result << 3) + UCHAR(*++string); diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index d7d8d33..33c9f77 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -2347,7 +2347,7 @@ UpdateStringOfFsPath( /* Steal copy's string rep */ pathPtr->bytes = Tcl_GetStringFromObj(copy, &cwdLen); pathPtr->length = cwdLen; - TclInitStringRep(copy, NULL, 0); + TclInitEmptyStringRep(copy); TclDecrRefCount(copy); } diff --git a/generic/tclResult.c b/generic/tclResult.c index c06a73a..be8c2fd 100644 --- a/generic/tclResult.c +++ b/generic/tclResult.c @@ -495,7 +495,7 @@ Tcl_SetErrorCode( */ va_start(argList, interp); - errorObj = Tcl_NewObj(); + TclNewObj(errorObj); /* * Scan through the arguments one at a time, appending them to the diff --git a/generic/tclScan.c b/generic/tclScan.c index 774d499..42838ac 100644 --- a/generic/tclScan.c +++ b/generic/tclScan.c @@ -1097,7 +1097,8 @@ Tcl_ScanObjCmd( * We create an empty Tcl_Obj to fill missing values rather than * allocating a new Tcl_Obj every time. See test scan-bigdata-XX. */ - Tcl_Obj *emptyObj = Tcl_NewObj(); + Tcl_Obj *emptyObj; + TclNewObj(emptyObj); Tcl_IncrRefCount(emptyObj); TclNewObj(objPtr); for (i = 0; code == TCL_OK && i < totalVars; i++) { diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index be807cd..2e42e98 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -610,7 +610,7 @@ Tcl_GetUniChar( int TclGetUniChar( - Tcl_Obj *objPtr, /* The object to get the Unicode charater + Tcl_Obj *objPtr, /* The object to get the Unicode character * from. */ Tcl_Size index) /* Get the index'th Unicode character. */ { @@ -751,7 +751,7 @@ Tcl_GetRange( Tcl_Size length = 0; if (first < 0) { - first = TCL_INDEX_START; + first = 0; } /* @@ -1082,9 +1082,9 @@ Tcl_AttemptSetObjLength( char *newBytes; if (objPtr->bytes == &tclEmptyString) { - newBytes = (char *)Tcl_AttemptAlloc(length + 1); + newBytes = (char *)Tcl_AttemptAlloc(length + 1U); } else { - newBytes = (char *)Tcl_AttemptRealloc(objPtr->bytes, length + 1); + newBytes = (char *)Tcl_AttemptRealloc(objPtr->bytes, length + 1U); } if (newBytes == NULL) { return 0; @@ -1289,7 +1289,7 @@ Tcl_AppendLimitedToObj( Tcl_GetUnicode(objPtr); stringPtr = GET_STRING(objPtr); } - if (stringPtr->hasUnicode && (stringPtr->numChars+1) > 1) { + if (stringPtr->hasUnicode && (stringPtr->numChars) > 0) { AppendUtfToUnicodeRep(objPtr, bytes, toCopy); } else { AppendUtfToUtfRep(objPtr, bytes, toCopy); @@ -1300,7 +1300,7 @@ Tcl_AppendLimitedToObj( } stringPtr = GET_STRING(objPtr); - if (stringPtr->hasUnicode && (stringPtr->numChars+1) > 1) { + if (stringPtr->hasUnicode && (stringPtr->numChars) > 0) { AppendUtfToUnicodeRep(objPtr, ellipsis, eLen); } else { AppendUtfToUtfRep(objPtr, ellipsis, eLen); @@ -1949,7 +1949,7 @@ Tcl_AppendFormatToObj( } gotSequential = 1; } - if (objIndex < 0 || objIndex >= objc) { + if ((objIndex < 0) || (objIndex >= objc)) { msg = badIndex[gotXpg]; errCode = gotXpg ? "INDEXRANGE" : "FIELDVARMISMATCH"; goto errorMsg; @@ -2538,7 +2538,7 @@ Tcl_AppendFormatToObj( goto errorMsg; } bytes = TclGetString(segment); - if (!Tcl_AttemptSetObjLength(segment, snprintf(bytes, length, spec, d))) { + if (!Tcl_AttemptSetObjLength(segment, snprintf(bytes, segment->length, spec, d))) { msg = overflow; errCode = "OVERFLOW"; goto errorMsg; @@ -3095,7 +3095,6 @@ TclStringRepeat( (count - done) * length); } return objResultPtr; - } /* @@ -3133,8 +3132,14 @@ TclStringCat( /* assert ( objc >= 0 ) */ if (objc <= 1) { - /* Negative (shouldn't be), one or no objects; return first or empty */ - return objc == 1 ? objv[0] : Tcl_NewObj(); + if (objc != 1) { + /* Negative (shouldn't be) no objects; return empty */ + Tcl_Obj *obj; + TclNewObj(obj); + return obj; + } + /* One object; return first */ + return objv[0]; } /* assert ( objc >= 2 ) */ @@ -3434,7 +3439,7 @@ TclStringCat( if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) { if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "concatenation failed: unable to alloc %" TCL_Z_MODIFIER "u bytes", + "concatenation failed: unable to alloc %" TCL_SIZE_MODIFIER "d bytes", length)); Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); } @@ -3450,7 +3455,7 @@ TclStringCat( Tcl_DecrRefCount(objResultPtr); if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "concatenation failed: unable to alloc %" TCL_Z_MODIFIER "u bytes", + "concatenation failed: unable to alloc %" TCL_SIZE_MODIFIER "d bytes", length)); Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); } @@ -3575,7 +3580,7 @@ TclStringCmp( reqlength *= sizeof(Tcl_UniChar); } } else { - memCmpFn = (memCmpFn_t) TclUniCharNcmp; + memCmpFn = (memCmpFn_t)(void *)TclUniCharNcmp; } } } @@ -3633,11 +3638,11 @@ TclStringCmp( */ if ((reqlength < 0) && !nocase) { - memCmpFn = (memCmpFn_t) TclpUtfNcmp2; + memCmpFn = (memCmpFn_t)(void *)TclpUtfNcmp2; } else { s1len = Tcl_NumUtfChars(s1, s1len); s2len = Tcl_NumUtfChars(s2, s2len); - memCmpFn = (memCmpFn_t) + memCmpFn = (memCmpFn_t)(void *) (nocase ? Tcl_UtfNcasecmp : Tcl_UtfNcmp); } } @@ -4426,7 +4431,7 @@ UpdateStringOfString( stringPtr->allocated = 0; if (stringPtr->numChars == 0) { - TclInitStringRep(objPtr, NULL, 0); + TclInitEmptyStringRep(objPtr); } else { (void) ExtendStringRepWithUnicode(objPtr, stringPtr->unicode, stringPtr->numChars); diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c index 48e7415..e9f7157 100644 --- a/generic/tclZipfs.c +++ b/generic/tclZipfs.c @@ -1902,7 +1902,7 @@ ListMountPoints( return (ZipFS.zipHash.numEntries ? TCL_OK : TCL_BREAK); } - resultList = Tcl_NewObj(); + TclNewObj(resultList); for (hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); hPtr; hPtr = Tcl_NextHashEntry(&search)) { zf = (ZipFile *) Tcl_GetHashValue(hPtr); diff --git a/library/clock.tcl b/library/clock.tcl index be4abf8..d1a76e7 100644 --- a/library/clock.tcl +++ b/library/clock.tcl @@ -310,28 +310,28 @@ proc ::tcl::clock::Initialize {} { {-43200 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Pacific/Kwajalein {-39600 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Pacific/Midway {-36000 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Pacific/Honolulu - {-32400 0 3600 0 11 0 1 2 0 0 0 0 3 0 2 2 0 0 0} :America/Anchorage - {-28800 0 3600 0 11 0 1 2 0 0 0 0 3 0 2 2 0 0 0} :America/Los_Angeles - {-28800 0 3600 0 10 0 5 2 0 0 0 0 4 0 1 2 0 0 0} :America/Tijuana - {-25200 0 3600 0 11 0 1 2 0 0 0 0 3 0 2 2 0 0 0} :America/Denver - {-25200 0 3600 0 10 0 5 2 0 0 0 0 4 0 1 2 0 0 0} :America/Chihuahua + {-32400 0 3600 0 11 0 1 2 0 0 0 0 3 0 2 2 0 0 0} :America/Anchorage + {-28800 0 3600 0 11 0 1 2 0 0 0 0 3 0 2 2 0 0 0} :America/Los_Angeles + {-28800 0 3600 0 10 0 5 2 0 0 0 0 4 0 1 2 0 0 0} :America/Tijuana + {-25200 0 3600 0 11 0 1 2 0 0 0 0 3 0 2 2 0 0 0} :America/Denver + {-25200 0 3600 0 10 0 5 2 0 0 0 0 4 0 1 2 0 0 0} :America/Chihuahua {-25200 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :America/Phoenix {-21600 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :America/Regina {-21600 0 3600 0 11 0 1 2 0 0 0 0 3 0 2 2 0 0 0} :America/Chicago - {-21600 0 3600 0 10 0 5 2 0 0 0 0 4 0 1 2 0 0 0} :America/Mexico_City + {-21600 0 3600 0 10 0 5 2 0 0 0 0 4 0 1 2 0 0 0} :America/Mexico_City {-18000 0 3600 0 11 0 1 2 0 0 0 0 3 0 2 2 0 0 0} :America/New_York {-18000 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :America/Indianapolis {-14400 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :America/Caracas - {-14400 0 3600 0 3 6 2 23 59 59 999 0 10 6 2 23 59 59 999} + {-14400 0 3600 0 3 6 2 23 59 59 999 0 10 6 2 23 59 59 999} :America/Santiago - {-14400 0 3600 0 2 0 5 2 0 0 0 0 11 0 1 2 0 0 0} :America/Manaus - {-14400 0 3600 0 11 0 1 2 0 0 0 0 3 0 2 2 0 0 0} :America/Halifax + {-14400 0 3600 0 2 0 5 2 0 0 0 0 11 0 1 2 0 0 0} :America/Manaus + {-14400 0 3600 0 11 0 1 2 0 0 0 0 3 0 2 2 0 0 0} :America/Halifax {-12600 0 3600 0 10 0 5 2 0 0 0 0 4 0 1 2 0 0 0} :America/St_Johns {-10800 0 3600 0 2 0 2 2 0 0 0 0 10 0 3 2 0 0 0} :America/Sao_Paulo {-10800 0 3600 0 10 0 5 2 0 0 0 0 4 0 1 2 0 0 0} :America/Godthab {-10800 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :America/Buenos_Aires - {-10800 0 3600 0 2 0 5 2 0 0 0 0 11 0 1 2 0 0 0} :America/Bahia - {-10800 0 3600 0 3 0 2 2 0 0 0 0 10 0 1 2 0 0 0} :America/Montevideo + {-10800 0 3600 0 2 0 5 2 0 0 0 0 11 0 1 2 0 0 0} :America/Bahia + {-10800 0 3600 0 3 0 2 2 0 0 0 0 10 0 1 2 0 0 0} :America/Montevideo {-7200 0 3600 0 9 0 5 2 0 0 0 0 3 0 5 2 0 0 0} :America/Noronha {-3600 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Atlantic/Azores {-3600 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Atlantic/Cape_Verde @@ -339,22 +339,22 @@ proc ::tcl::clock::Initialize {} { {0 0 3600 0 10 0 5 2 0 0 0 0 3 0 5 1 0 0 0} :Europe/London {3600 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Africa/Kinshasa {3600 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :CET - {7200 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Africa/Harare - {7200 0 3600 0 9 4 5 23 59 59 0 0 4 4 5 23 59 59 0} + {7200 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Africa/Harare + {7200 0 3600 0 9 4 5 23 59 59 0 0 4 4 5 23 59 59 0} :Africa/Cairo {7200 0 3600 0 10 0 5 4 0 0 0 0 3 0 5 3 0 0 0} :Europe/Helsinki - {7200 0 3600 0 9 0 3 2 0 0 0 0 3 5 5 2 0 0 0} :Asia/Jerusalem + {7200 0 3600 0 9 0 3 2 0 0 0 0 3 5 5 2 0 0 0} :Asia/Jerusalem {7200 0 3600 0 9 0 5 1 0 0 0 0 3 0 5 0 0 0 0} :Europe/Bucharest {7200 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Europe/Athens - {7200 0 3600 0 9 5 5 1 0 0 0 0 3 4 5 0 0 0 0} :Asia/Amman - {7200 0 3600 0 10 6 5 23 59 59 999 0 3 0 5 0 0 0 0} + {7200 0 3600 0 9 5 5 1 0 0 0 0 3 4 5 0 0 0 0} :Asia/Amman + {7200 0 3600 0 10 6 5 23 59 59 999 0 3 0 5 0 0 0 0} :Asia/Beirut - {7200 0 -3600 0 4 0 1 2 0 0 0 0 9 0 1 2 0 0 0} :Africa/Windhoek + {7200 0 -3600 0 4 0 1 2 0 0 0 0 9 0 1 2 0 0 0} :Africa/Windhoek {10800 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Riyadh {10800 0 3600 0 10 0 1 4 0 0 0 0 4 0 1 3 0 0 0} :Asia/Baghdad {10800 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Europe/Moscow {12600 0 3600 0 9 2 4 2 0 0 0 0 3 0 1 2 0 0 0} :Asia/Tehran - {14400 0 3600 0 10 0 5 5 0 0 0 0 3 0 5 4 0 0 0} :Asia/Baku + {14400 0 3600 0 10 0 5 5 0 0 0 0 3 0 5 4 0 0 0} :Asia/Baku {14400 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Muscat {14400 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Asia/Tbilisi {16200 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Kabul @@ -584,8 +584,8 @@ proc ::tcl::clock::Initialize {} { jst +0900 \ kst +0900 \ cast +0930 \ - jdt +1000 \ - kdt +1000 \ + jdt +1000 \ + kdt +1000 \ cadt +1030 \ east +1000 \ eadt +1030 \ @@ -1158,8 +1158,8 @@ proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} { } proc $procName {clockval timezone} " - $preFormatCode - return \[::format [list $formatString] $substituents\] + $preFormatCode + return \[::format [list $formatString] $substituents\] " # puts [list $procName [info args $procName] [info body $procName]] @@ -1173,7 +1173,7 @@ proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} { # # Inputs a count of seconds since the Posix Epoch as a time of day. # -# The 'clock format' command scans times of day on input. Refer to the user +# The 'clock scan' command scans times of day on input. Refer to the user # documentation to see what it does. # #---------------------------------------------------------------------- @@ -1189,10 +1189,10 @@ proc ::tcl::clock::scan { args } { return -code error \ -errorcode [list CLOCK wrongNumArgs] \ "wrong \# args: should be\ - \"$cmdName string\ - ?-base seconds?\ - ?-format string? ?-gmt boolean?\ - ?-locale LOCALE? ?-timezone ZONE?\"" + \"$cmdName string\ + ?-base seconds?\ + ?-format string? ?-gmt boolean?\ + ?-locale LOCALE? ?-timezone ZONE?\"" } # Set defaults @@ -1207,28 +1207,31 @@ proc ::tcl::clock::scan { args } { # Pick up command line options. foreach { flag value } [lreplace $args 0 0] { - set saw($flag) {} switch -exact -- $flag { -b - -ba - -bas - -base { set base $value } -f - -fo - -for - -form - -forma - -format { + set saw(-format) {} set format $value } -g - -gm - -gmt { + set saw(-gmt) {} set gmt $value } -l - -lo - -loc - -loca - -local - -locale { + set saw(-locale) {} set locale [string tolower $value] } -t - -ti - -tim - -time - -timez - -timezo - -timezon - -timezone { + set saw(-timezone) {} set timezone $value } default { return -code error \ -errorcode [list CLOCK badOption $flag] \ "bad option \"$flag\",\ - must be -base, -format, -gmt, -locale or -timezone" + must be -base, -format, -gmt, -locale or -timezone" } } } @@ -1975,7 +1978,7 @@ proc ::tcl::clock::ParseClockScanFormat {formatString locale} { # being processed - they're always absolute if { ![dict exists $fieldSet seconds] - && ![dict exists $fieldSet starDate] } { + && ![dict exists $fieldSet starDate] } { append procBody { if { [dict get $date julianDay] > 5373484 } { return -code error -errorcode [list CLOCK dateTooLarge] \ @@ -2379,8 +2382,8 @@ proc ::tcl::clock::LoadWindowsDateTimeFormats { locale } { M %N yyyy %Y yy %y - y %y - gg {} + y %y + gg {} } $unquoted] if { $quoted eq {} } { set quote ' @@ -2409,8 +2412,8 @@ proc ::tcl::clock::LoadWindowsDateTimeFormats { locale } { M %N yyyy %Y yy %y - y %y - gg {} + y %y + gg {} } $unquoted] if { $quoted eq {} } { set quote ' @@ -2989,19 +2992,19 @@ proc ::tcl::clock::GetSystemTimeZone {} { } elseif {[set result [getenv TZ]] ne {}} { set timezone $result } else { - # Cache the time zone only if it was detected by one of the - # expensive methods. - if { [info exists CachedSystemTimeZone] } { - set timezone $CachedSystemTimeZone - } elseif { $::tcl_platform(platform) eq {windows} } { - set timezone [GuessWindowsTimeZone] - } elseif { [file exists /etc/localtime] - && ![catch {ReadZoneinfoFile \ - Tcl/Localtime /etc/localtime}] } { - set timezone :Tcl/Localtime - } else { - set timezone :localtime - } + # Cache the time zone only if it was detected by one of the + # expensive methods. + if { [info exists CachedSystemTimeZone] } { + set timezone $CachedSystemTimeZone + } elseif { $::tcl_platform(platform) eq {windows} } { + set timezone [GuessWindowsTimeZone] + } elseif { [file exists /etc/localtime] + && ![catch {ReadZoneinfoFile \ + Tcl/Localtime /etc/localtime}] } { + set timezone :Tcl/Localtime + } else { + set timezone :localtime + } set CachedSystemTimeZone $timezone } if { ![dict exists $TimeZoneBad $timezone] } { @@ -3608,7 +3611,7 @@ proc ::tcl::clock::ParsePosixTimeZone { tz } { # 4 - Standard time zone offset, minutes : ([[:digit:]]{1,2}) (?: - # 5 - Standard time zone offset, seconds + # 5 - Standard time zone offset, seconds : ([[:digit:]]{1,2} ) )? )? @@ -3616,7 +3619,7 @@ proc ::tcl::clock::ParsePosixTimeZone { tz } { # 6 - DST time zone name ([[:alpha:]]+ | <[-+[:alnum:]]+>) (?: - (?: + (?: # 7 - DST time zone offset, signum ([-+]?) # 8 - DST time zone offset, hours @@ -3625,17 +3628,17 @@ proc ::tcl::clock::ParsePosixTimeZone { tz } { # 9 - DST time zone offset, minutes : ([[:digit:]]{1,2}) (?: - # 10 - DST time zone offset, seconds + # 10 - DST time zone offset, seconds : ([[:digit:]]{1,2}) )? )? )? - (?: + (?: , (?: # 11 - Optional J in n and Jn form 12 - Day of year - ( J ? ) ( [[:digit:]]+ ) - | M + ( J ? ) ( [[:digit:]]+ ) + | M # 13 - Month number 14 - Week of month 15 - Day of week ( [[:digit:]] + ) [.] ( [[:digit:]] + ) @@ -3644,7 +3647,7 @@ proc ::tcl::clock::ParsePosixTimeZone { tz } { (?: # 16 - Start time of DST - hours / ( [[:digit:]]{1,2} ) - (?: + (?: # 17 - Start time of DST - minutes : ( [[:digit:]]{1,2} ) (?: @@ -3656,8 +3659,8 @@ proc ::tcl::clock::ParsePosixTimeZone { tz } { , (?: # 19 - Optional J in n and Jn form 20 - Day of year - ( J ? ) ( [[:digit:]]+ ) - | M + ( J ? ) ( [[:digit:]]+ ) + | M # 21 - Month number 22 - Week of month 23 - Day of week ( [[:digit:]] + ) [.] ( [[:digit:]] + ) @@ -3666,7 +3669,7 @@ proc ::tcl::clock::ParsePosixTimeZone { tz } { (?: # 24 - End time of DST - hours / ( [[:digit:]]{1,2} ) - (?: + (?: # 25 - End time of DST - minutes : ( [[:digit:]]{1,2} ) (?: @@ -3675,9 +3678,9 @@ proc ::tcl::clock::ParsePosixTimeZone { tz } { )? )? )? - )? + )? )? - )? + )? $ } $tz -> x(stdName) x(stdSignum) x(stdHours) x(stdMinutes) x(stdSeconds) \ x(dstName) x(dstSignum) x(dstHours) x(dstMinutes) x(dstSeconds) \ @@ -4243,8 +4246,8 @@ proc ::tcl::clock::add { clockval args } { return -code error \ -errorcode [list CLOCK wrongNumArgs] \ "wrong \# args: should be\ - \"$cmdName clockval ?number units?...\ - ?-gmt boolean? ?-locale LOCALE? ?-timezone ZONE?\"" + \"$cmdName clockval ?number units?...\ + ?-gmt boolean? ?-locale LOCALE? ?-timezone ZONE?\"" } if { [catch { expr {wide($clockval)} } result] } { return -code error $result @@ -4261,6 +4264,7 @@ proc ::tcl::clock::add { clockval args } { } else { switch -exact -- $a { -g - -gm - -gmt { + set saw(-gmt) {} set gmt $b } -l - -lo - -loc - -loca - -local - -locale { @@ -4268,12 +4272,13 @@ proc ::tcl::clock::add { clockval args } { } -t - -ti - -tim - -time - -timez - -timezo - -timezon - -timezone { + set saw(-timezone) {} set timezone $b } default { throw [list CLOCK badOption $a] \ "bad option \"$a\",\ - must be -gmt, -locale or -timezone" + must be -gmt, -locale or -timezone" } } } @@ -4338,7 +4343,7 @@ proc ::tcl::clock::add { clockval args } { default { throw [list CLOCK badUnit $unit] \ "unknown unit \"$unit\", must be \ - years, months, weeks, days, hours, minutes or seconds" + years, months, weeks, days, hours, minutes or seconds" } } } @@ -4498,10 +4503,10 @@ proc ::tcl::clock::ChangeCurrentLocale {args} { variable TimeZoneBad foreach p [info procs [namespace current]::scanproc'*'current] { - rename $p {} + rename $p {} } foreach p [info procs [namespace current]::formatproc'*'current] { - rename $p {} + rename $p {} } catch {array unset FormatProc *'current} diff --git a/tests/clock.test b/tests/clock.test index 0b385c9..4bac104 100644 --- a/tests/clock.test +++ b/tests/clock.test @@ -36768,6 +36768,14 @@ test clock-57.1 {clock scan - abbreviated options} { clock scan 1970-01-01 -f %Y-%m-%d -g true } 0 +test clock-57.2 {clock scan - not -gmt and -timezone in the same call} { + catch {clock scan 1970-01-01 -format %Y-%m-%d -gmt true -timezone :Europe/Berlin} +} 1 + +test clock-57.3 {clock scan - not -g and -timezone in the same call} { + catch {clock scan 1970-01-01 -format %Y-%m-%d -g true -timezone :Europe/Berlin} +} 1 + test clock-58.1 {clock l10n - Japanese localisation} {*}{ -setup { proc backslashify { string } { @@ -36980,6 +36988,15 @@ test clock-65.1 {clock add, bad option [Bug 2481670]} {*}{ -result {bad option "-foo"*} } +test clock-65.2 {clock add with both -timezone and -gmt} {*}{ + -body { + clock add 0 1 year -timezone :CET -gmt true + } + -match glob + -returnCodes error + -result {cannot use -gmt and -timezone in same call} +} + test clock-66.1 {clock scan, no date, never-before-seen timezone} {*}{ -setup { ::tcl::clock::ClearCaches diff --git a/tests/io.test b/tests/io.test index 5acd553..db114e6 100644 --- a/tests/io.test +++ b/tests/io.test @@ -2428,7 +2428,7 @@ test io-28.3 {CloseChannel, not called before output queue is empty} \ close $f set x 01234567890123456789012345678901 for {set i 0} {$i < 11} {incr i} { - set x "$x$x" + set x "$x$x" } set f [open $path(output) w] close $f @@ -4633,29 +4633,29 @@ test io-33.10 {Tcl_Gets, exercising double buffering} { } 300 test io-33.11 {TclGetsObjBinary, [10dc6daa37]} -setup { proc driver {cmd args} { - variable buffer - variable index - set chan [lindex $args 0] - switch -- $cmd { - initialize { - set index($chan) 0 - set buffer($chan) ....... - return {initialize finalize watch read} - } - finalize { - unset index($chan) buffer($chan) - return - } - watch {} - read { - set n [lindex $args 1] + variable buffer + variable index + set chan [lindex $args 0] + switch -- $cmd { + initialize { + set index($chan) 0 + set buffer($chan) ....... + return {initialize finalize watch read} + } + finalize { + unset index($chan) buffer($chan) + return + } + watch {} + read { + set n [lindex $args 1] if {$n > 3} {set n 3} - set new [expr {$index($chan) + $n}] - set result [string range $buffer($chan) $index($chan) $new-1] - set index($chan) $new - return $result - } - } + set new [expr {$index($chan) + $n}] + set result [string range $buffer($chan) $index($chan) $new-1] + set index($chan) $new + return $result + } + } } } -body { set c [chan create read [namespace which driver]] @@ -6448,10 +6448,10 @@ test io-47.3 {deleting fileevent on interpreter delete} {testfevent fileevent} { fileevent $f readable {script 1} fileevent $f2 readable {script 2} testfevent cmd "fileevent $f3 readable {script 3} - fileevent $f4 readable {script 4}" + fileevent $f4 readable {script 4}" testfevent delete set x [list [fileevent $f readable] [fileevent $f2 readable] \ - [fileevent $f3 readable] [fileevent $f4 readable]] + [fileevent $f3 readable] [fileevent $f4 readable]] close $f close $f2 close $f3 @@ -6495,7 +6495,7 @@ test io-47.6 {file events on shared files, deleting file events} {testfevent fil fileevent $f readable {script 2} fileevent $f readable {} set x [list [testfevent cmd "fileevent $f readable"] \ - [fileevent $f readable]] + [fileevent $f readable]] testfevent delete close $f set x @@ -7756,7 +7756,7 @@ test io-52.22 {TclCopyChannel & encodings} -setup { fconfigure $in -encoding ascii -profile strict fconfigure $out -encoding koi8-r -translation lf proc ::xxx args { - set ::s0 $args + set ::s0 $args } fcopy $in $out -command ::xxx @@ -7783,7 +7783,7 @@ test io-52.23 {TclCopyChannel & encodings} -setup { fconfigure $in -encoding utf-8 fconfigure $out -encoding ascii -translation lf -profile strict proc ::xxx args { - set ::s0 $args + set ::s0 $args } fcopy $in $out -command ::xxx @@ -7846,7 +7846,7 @@ test io-53.2 {CopyData} {fcopy} { set s1 [file size $thisScript] set s2 [file size $path(test1)] if {("$s1" == "$s2") && ($s0 == $s1)} { - lappend result ok + lappend result ok } set result } {0 0 ok} @@ -9289,7 +9289,7 @@ test io-75.6 {invalid utf-8 encoding, gets is not ignored (-profile strict)} -se flush $f seek $f 0 fconfigure $f -encoding utf-8 -buffering none -eofchar {} \ - -translation lf -profile strict + -translation lf -profile strict } -body { gets $f } -cleanup { @@ -9309,14 +9309,14 @@ test io-75.7 { flush $f seek $f 0 fconfigure $f -encoding utf-8 -buffering none -eofchar {} -translation lf \ - -profile strict + -profile strict } -body { - read $f + list [catch {read $f} msg] $msg } -cleanup { close $f removeFile io-75.7 -} -match glob -returnCodes 1 -result {error reading "file*":\ - invalid or incomplete multibyte or wide character} +} -match glob -result {1 {error reading "file*":\ + invalid or incomplete multibyte or wide character}} test io-75.8 {invalid utf-8 encoding eof handling (-profile strict)} -setup { set fn [makeFile {} io-75.8] @@ -9341,7 +9341,6 @@ test io-75.8 {invalid utf-8 encoding eof handling (-profile strict)} -setup { } -result {41 1 {}} test io-75.8.eoflater {invalid utf-8 encoding eof handling (-profile strict)} -setup { - set res {} set fn [makeFile {} io-75.8] set f [open $fn w+] # This also configures the channel encoding profile as strict. @@ -9353,9 +9352,7 @@ test io-75.8.eoflater {invalid utf-8 encoding eof handling (-profile strict)} -s fconfigure $f -encoding utf-8 -buffering none -eofchar \x1A \ -translation lf -profile strict } -body { - set status [catch {read $f} cres copts] - lappend res $status - lappend res [eof $f] + set res [list [catch {read $f} cres] [eof $f]] chan configure $f -encoding iso8859-1 lappend res [read $f 1] chan configure $f -encoding utf-8 @@ -9382,8 +9379,7 @@ test io-strict-multibyte-eof { seek $chan 0 chan configure $chan -encoding utf-8 -profile strict } -body { - set status [catch {read $chan 1} cres] - lappend res $status $cres + list [catch {read $chan 1} cres] $cres } -cleanup { close $chan unset res @@ -9452,8 +9448,7 @@ test io-75.11 {shiftjis encoding error read results in raw bytes} -setup { } -body { set d [read $f] binary scan $d H* hd - lappend hd [catch {set d [read $f]} msg] - lappend hd $msg + lappend hd [catch {set d [read $f]} msg] $msg } -cleanup { close $f removeFile io-75.11 @@ -9504,8 +9499,7 @@ test io-75.13 { } -body { set d [read $f] binary scan $d H* hd - lappend hd [catch {read $f} msg] - lappend hd $msg + lappend hd [catch {read $f} msg] $msg } -cleanup { close $f removeFile io-75.13 @@ -9519,8 +9513,8 @@ test io-75.14 { } -setup { set chan [file tempfile] fconfigure $chan -encoding binary - # \xc0\n is an invalid utf-8 sequence - puts -nonewline $chan a\nb\nc\xc0\nd\n + # \xC0\n is an invalid utf-8 sequence + puts -nonewline $chan a\nb\nc\xC0\nd\n flush $chan seek $chan 0 fconfigure $chan -encoding utf-8 -buffering none -eofchar {} \ @@ -9528,8 +9522,7 @@ test io-75.14 { } -body { lappend res [gets $chan] lappend res [gets $chan] - set status [catch {gets $chan} cres copts] - lappend res $status $cres + lappend res [catch {gets $chan} cres] $cres chan configure $chan -profile tcl8 lappend res [gets $chan] lappend res [gets $chan] @@ -9546,18 +9539,16 @@ test io-75.15 { set res {} set chan [file tempfile] fconfigure $chan -encoding binary - # \xc0\x40 is an invalid utf-8 sequence - puts $chan hello\nAB\nCD\xc0\x40EF\nGHI + # \xC0\x40 is an invalid utf-8 sequence + puts $chan hello\nAB\nCD\xC0\x40EF\nGHI seek $chan 0 } -body { #Now try to read it with [gets] fconfigure $chan -encoding utf-8 -profile strict lappend res [gets $chan] lappend res [gets $chan] - set status [catch {gets $chan} cres copts] - lappend res $status $cres - set status [catch {gets $chan} cres copts] - lappend res $status $cres + lappend res [catch {gets $chan} cres] $cres + lappend res [catch {gets $chan} cres] $cres chan configure $chan -translation binary set data [read $chan 4] foreach char [split $data {}] { diff --git a/tests/ioCmd.test b/tests/ioCmd.test index 471659a..e603731 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -229,7 +229,7 @@ test iocmd-8.4 {fconfigure command} -setup { fconfigure $f1 froboz } -returnCodes error -cleanup { close $f1 -} -result [expectedOpts "froboz" {}] +} -result [expectedOpts "froboz" -stat] test iocmd-8.5 {fconfigure command} -returnCodes error -body { fconfigure stdin -buffering froboz } -result {bad value for -buffering: must be one of full, line, or none} @@ -592,7 +592,28 @@ test ioCmd-13.11 {open ... a+ must not use O_APPEND: Bug 1773127} -setup { } -cleanup { removeFile $f } -result 341234x6 - +test ioCmd-13.12 {open file produces something that has fconfigure -stat} -setup { + set f [makeFile {} iocmd13_12] + set result {} +} -body { + set fd [open $f wb] + set result [dict get [fconfigure $fd -stat] type] + fconfigure $fd -buffering none + puts -nonewline $fd abc + # Three ways of getting the size; all should agree! + lappend result [tell $fd] [file size $f] \ + [dict get [fconfigure $fd -stat] size] + puts -nonewline $fd def + lappend result [tell $fd] [file size $f] \ + [dict get [fconfigure $fd -stat] size] + puts -nonewline $fd ghi + lappend result [tell $fd] [file size $f] \ + [dict get [fconfigure $fd -stat] size] + close $fd + return $result +} -cleanup { + removeFile $f +} -result {file 3 3 3 6 6 6 9 9 9} test iocmd-14.1 {file id parsing errors} { list [catch {eof gorp} msg] $msg $::errorCode diff --git a/unix/configure b/unix/configure index 4c54fbe..c0f7a32 100755 --- a/unix/configure +++ b/unix/configure @@ -9506,6 +9506,14 @@ printf "%s\n" "#define HAVE_STRUCT_STAT_ST_BLKSIZE 1" >>confdefs.h fi +ac_fn_c_check_member "$LINENO" "struct stat" "st_rdev" "ac_cv_member_struct_stat_st_rdev" "$ac_includes_default" +if test "x$ac_cv_member_struct_stat_st_rdev" = xyes +then : + +printf "%s\n" "#define HAVE_STRUCT_STAT_ST_RDEV 1" >>confdefs.h + + +fi fi ac_fn_c_check_type "$LINENO" "blkcnt_t" "ac_cv_type_blkcnt_t" "$ac_includes_default" diff --git a/unix/configure.ac b/unix/configure.ac index 238e47a..17da218 100644 --- a/unix/configure.ac +++ b/unix/configure.ac @@ -371,7 +371,7 @@ SC_TIME_HANDLER #-------------------------------------------------------------------- if test "$ac_cv_cygwin" != "yes"; then - AC_CHECK_MEMBERS([struct stat.st_blocks, struct stat.st_blksize]) + AC_CHECK_MEMBERS([struct stat.st_blocks, struct stat.st_blksize, struct stat.st_rdev]) fi AC_CHECK_TYPES([blkcnt_t]) AC_CHECK_FUNC(fstatfs, , [AC_DEFINE(NO_FSTATFS, 1, [Do we have fstatfs()?])]) diff --git a/unix/tclConfig.h.in b/unix/tclConfig.h.in index 658ba11..c7573ef 100644 --- a/unix/tclConfig.h.in +++ b/unix/tclConfig.h.in @@ -244,6 +244,9 @@ /* Define to 1 if `st_blocks' is a member of `struct stat'. */ #undef HAVE_STRUCT_STAT_ST_BLOCKS +/* Define to 1 if `st_rdev' is a member of `struct stat'. */ +#undef HAVE_STRUCT_STAT_ST_RDEV + /* Define to 1 if you have the <sys/epoll.h> header file. */ #undef HAVE_SYS_EPOLL_H diff --git a/unix/tclUnixChan.c b/unix/tclUnixChan.c index 6feaeae..eea1453 100644 --- a/unix/tclUnixChan.c +++ b/unix/tclUnixChan.c @@ -124,6 +124,9 @@ static int FileCloseProc(void *instanceData, Tcl_Interp *interp, int flags); static int FileGetHandleProc(void *instanceData, int direction, void **handlePtr); +static int FileGetOptionProc(void *instanceData, + Tcl_Interp *interp, const char *optionName, + Tcl_DString *dsPtr); static int FileInputProc(void *instanceData, char *buf, int toRead, int *errorCode); static int FileOutputProc(void *instanceData, @@ -164,7 +167,7 @@ static const Tcl_ChannelType fileChannelType = { FileOutputProc, /* Output proc. */ NULL, NULL, /* Set option proc. */ - NULL, /* Get option proc. */ + FileGetOptionProc, /* Get option proc. */ FileWatchProc, /* Initialize notifier. */ FileGetHandleProc, /* Get OS handles out of channel. */ FileCloseProc, /* close2proc. */ @@ -275,7 +278,7 @@ FileInputProc( */ do { - bytesRead = read(fsPtr->fd, buf, toRead); + bytesRead = read(fsPtr->fd, buf, (size_t)toRead); } while ((bytesRead < 0) && (errno == EINTR)); if (bytesRead < 0) { @@ -324,7 +327,7 @@ FileOutputProc( return 0; } - written = write(fsPtr->fd, buf, toWrite); + written = write(fsPtr->fd, buf, (size_t)toWrite); if (written >= 0) { return written; } @@ -534,6 +537,176 @@ FileGetHandleProc( return TCL_ERROR; } +/* + *---------------------------------------------------------------------- + * + * FileGetOptionProc -- + * + * Gets an option associated with an open file. If the optionName arg is + * non-NULL, retrieves the value of that option. If the optionName arg is + * NULL, retrieves a list of alternating option names and values for the + * given channel. + * + * Results: + * A standard Tcl result. Also sets the supplied DString to the string + * value of the option(s) returned. Sets error message if needed + * (by calling Tcl_BadChannelOption). + * + *---------------------------------------------------------------------- + */ + +static inline void +StoreElementInDict( + Tcl_Obj *dictObj, + const char *name, + Tcl_Obj *valueObj) +{ + /* + * We assume that the dict is being built fresh and that there's never any + * duplicate keys. + */ + + Tcl_Obj *nameObj = Tcl_NewStringObj(name, -1); + Tcl_DictObjPut(NULL, dictObj, nameObj, valueObj); +} + +static inline const char * +GetTypeFromMode( + int mode) +{ + /* + * TODO: deduplicate with tclCmdAH.c + */ + + if (S_ISREG(mode)) { + return "file"; + } else if (S_ISDIR(mode)) { + return "directory"; + } else if (S_ISCHR(mode)) { + return "characterSpecial"; + } else if (S_ISBLK(mode)) { + return "blockSpecial"; + } else if (S_ISFIFO(mode)) { + return "fifo"; +#ifdef S_ISLNK + } else if (S_ISLNK(mode)) { + return "link"; +#endif +#ifdef S_ISSOCK + } else if (S_ISSOCK(mode)) { + return "socket"; +#endif + } + return "unknown"; +} + +static Tcl_Obj * +StatOpenFile( + FileState *fsPtr) +{ + Tcl_StatBuf statBuf; /* Not allocated on heap; we're definitely + * API-synchronized with how Tcl is built! */ + Tcl_Obj *dictObj; + unsigned short mode; + + if (TclOSfstat(fsPtr->fd, &statBuf) < 0) { + return NULL; + } + + /* + * TODO: merge with TIP 594 implementation (it's silly to have a + * duplicate!) + */ + + TclNewObj(dictObj); +#define STORE_ELEM(name, value) StoreElementInDict(dictObj, name, value) + + STORE_ELEM("dev", Tcl_NewWideIntObj((long) statBuf.st_dev)); + STORE_ELEM("ino", Tcl_NewWideIntObj((Tcl_WideInt) statBuf.st_ino)); + STORE_ELEM("nlink", Tcl_NewWideIntObj((long) statBuf.st_nlink)); + STORE_ELEM("uid", Tcl_NewWideIntObj((long) statBuf.st_uid)); + STORE_ELEM("gid", Tcl_NewWideIntObj((long) statBuf.st_gid)); + STORE_ELEM("size", Tcl_NewWideIntObj((Tcl_WideInt) statBuf.st_size)); +#ifdef HAVE_STRUCT_STAT_ST_BLOCKS + STORE_ELEM("blocks", Tcl_NewWideIntObj((Tcl_WideInt) statBuf.st_blocks)); +#endif +#ifdef HAVE_STRUCT_STAT_ST_BLKSIZE + STORE_ELEM("blksize", Tcl_NewWideIntObj((long) statBuf.st_blksize)); +#endif +#ifdef HAVE_STRUCT_STAT_ST_RDEV + if (S_ISCHR(statBuf.st_mode) || S_ISBLK(statBuf.st_mode)) { + STORE_ELEM("rdev", Tcl_NewWideIntObj((long) statBuf.st_rdev)); + } +#endif + STORE_ELEM("atime", Tcl_NewWideIntObj( + Tcl_GetAccessTimeFromStat(&statBuf))); + STORE_ELEM("mtime", Tcl_NewWideIntObj( + Tcl_GetModificationTimeFromStat(&statBuf))); + STORE_ELEM("ctime", Tcl_NewWideIntObj( + Tcl_GetChangeTimeFromStat(&statBuf))); + mode = (unsigned short) statBuf.st_mode; + STORE_ELEM("mode", Tcl_NewWideIntObj(mode)); + STORE_ELEM("type", Tcl_NewStringObj(GetTypeFromMode(mode), -1)); +#undef STORE_ELEM + + return dictObj; +} + +static int +FileGetOptionProc( + void *instanceData, + Tcl_Interp *interp, + const char *optionName, + Tcl_DString *dsPtr) +{ + FileState *fsPtr = (FileState *)instanceData; + int valid = 0; /* Flag if valid option parsed. */ + int len; + + if (optionName == NULL) { + len = 0; + valid = 1; + } else { + len = strlen(optionName); + } + + /* + * Get option -stat + * Option is readonly and returned by [fconfigure chan -stat] but not + * returned by [fconfigure chan] without explicit option name. + */ + + if ((len > 1) && (strncmp(optionName, "-stat", len) == 0)) { + Tcl_Obj *dictObj = StatOpenFile(fsPtr); + const char *dictContents; + Tcl_Size dictLength; + + if (dictObj == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't read file channel status: %s", + Tcl_PosixError(interp))); + return TCL_ERROR; + } + + /* + * Transfer dictionary to the DString. Note that we don't do this as + * an element as this is an option that can't be retrieved with a + * general probe. + */ + + dictContents = Tcl_GetStringFromObj(dictObj, &dictLength); + Tcl_DStringAppend(dsPtr, dictContents, dictLength); + Tcl_DecrRefCount(dictObj); + return TCL_OK; + } + + if (valid) { + return TCL_OK; + } + return Tcl_BadChannelOption(interp, optionName, + "stat"); +} + #ifdef SUPPORTS_TTY /* *---------------------------------------------------------------------- diff --git a/unix/tclUnixFile.c b/unix/tclUnixFile.c index 41985ab..8606960 100644 --- a/unix/tclUnixFile.c +++ b/unix/tclUnixFile.c @@ -63,6 +63,7 @@ TclpFindExecutable( const char *name, *p; Tcl_StatBuf statBuf; Tcl_DString buffer, nameString, cwd, utfName; + Tcl_Obj *obj; if (argv0 == NULL) { return; @@ -138,7 +139,8 @@ TclpFindExecutable( p++; } } - TclSetObjNameOfExecutable(Tcl_NewObj(), NULL); + TclNewObj(obj); + TclSetObjNameOfExecutable(obj, NULL); goto done; /* @@ -161,7 +163,8 @@ TclpFindExecutable( } if (TclpGetCwd(NULL, &cwd) == NULL) { - TclSetObjNameOfExecutable(Tcl_NewObj(), NULL); + TclNewObj(obj); + TclSetObjNameOfExecutable(obj, NULL); goto done; } diff --git a/win/tclWinChan.c b/win/tclWinChan.c index 9535fdd..9f541f0 100644 --- a/win/tclWinChan.c +++ b/win/tclWinChan.c @@ -80,6 +80,9 @@ static int FileCloseProc(void *instanceData, static int FileEventProc(Tcl_Event *evPtr, int flags); static int FileGetHandleProc(void *instanceData, int direction, void **handlePtr); +static int FileGetOptionProc(ClientData instanceData, + Tcl_Interp *interp, const char *optionName, + Tcl_DString *dsPtr); static ThreadSpecificData *FileInit(void); static int FileInputProc(void *instanceData, char *buf, int toRead, int *errorCode); @@ -110,7 +113,7 @@ static const Tcl_ChannelType fileChannelType = { FileOutputProc, /* Output proc. */ NULL, NULL, /* Set option proc. */ - NULL, /* Get option proc. */ + FileGetOptionProc, /* Get option proc. */ FileWatchProc, /* Set up the notifier to watch the channel. */ FileGetHandleProc, /* Get an OS handle from channel. */ FileCloseProc, /* close2proc. */ @@ -129,6 +132,15 @@ static const Tcl_ChannelType fileChannelType = { #define SET_FLAG(var, flag) ((var) |= (flag)) #define CLEAR_FLAG(var, flag) ((var) &= ~(flag)) #define TEST_FLAG(value, flag) (((value) & (flag)) != 0) + +/* + * The number of 100-ns intervals between the Windows system epoch (1601-01-01 + * on the proleptic Gregorian calendar) and the Posix epoch (1970-01-01). + */ + +#define POSIX_EPOCH_AS_FILETIME \ + ((long long) 116444736 * (long long) 1000000000) + /* *---------------------------------------------------------------------- @@ -749,6 +761,195 @@ FileGetHandleProc( /* *---------------------------------------------------------------------- * + * FileGetOptionProc -- + * + * Gets an option associated with an open file. If the optionName arg is + * non-NULL, retrieves the value of that option. If the optionName arg is + * NULL, retrieves a list of alternating option names and values for the + * given channel. + * + * Results: + * A standard Tcl result. Also sets the supplied DString to the string + * value of the option(s) returned. Sets error message if needed + * (by calling Tcl_BadChannelOption). + * + *---------------------------------------------------------------------- + */ + +static inline ULONGLONG +CombineDwords( + DWORD hi, + DWORD lo) +{ + ULARGE_INTEGER converter; + + converter.LowPart = lo; + converter.HighPart = hi; + return converter.QuadPart; +} + +static inline void +StoreElementInDict( + Tcl_Obj *dictObj, + const char *name, + Tcl_Obj *valueObj) +{ + /* + * We assume that the dict is being built fresh and that there's never any + * duplicate keys. + */ + + Tcl_Obj *nameObj = Tcl_NewStringObj(name, -1); + Tcl_DictObjPut(NULL, dictObj, nameObj, valueObj); +} + +static inline time_t +ToCTime( + FILETIME fileTime) /* UTC time */ +{ + LARGE_INTEGER convertedTime; + + convertedTime.LowPart = fileTime.dwLowDateTime; + convertedTime.HighPart = (LONG) fileTime.dwHighDateTime; + + return (time_t) ((convertedTime.QuadPart - + (long long) POSIX_EPOCH_AS_FILETIME) / (long long) 10000000); +} + +static Tcl_Obj * +StatOpenFile( + FileInfo *infoPtr) +{ + DWORD attr; + int dev, nlink = 1; + unsigned short mode; + unsigned long long size, inode; + long long atime, ctime, mtime; + BY_HANDLE_FILE_INFORMATION data; + Tcl_Obj *dictObj; + + if (GetFileInformationByHandle(infoPtr->handle, &data) != TRUE) { + Tcl_SetErrno(ENOENT); + return NULL; + } + + atime = ToCTime(data.ftLastAccessTime); + mtime = ToCTime(data.ftLastWriteTime); + ctime = ToCTime(data.ftCreationTime); + attr = data.dwFileAttributes; + size = CombineDwords(data.nFileSizeHigh, data.nFileSizeLow); + nlink = data.nNumberOfLinks; + + /* + * Unfortunately our stat definition's inode field (unsigned short) will + * throw away most of the precision we have here, which means we can't + * rely on inode as a unique identifier of a file. We'd really like to do + * something like how we handle 'st_size'. + */ + + inode = CombineDwords(data.nFileIndexHigh, data.nFileIndexLow); + + dev = data.dwVolumeSerialNumber; + + /* + * Note that this code has no idea whether the file can be executed. + */ + + mode = (attr & FILE_ATTRIBUTE_DIRECTORY) ? S_IFDIR|S_IEXEC : S_IFREG; + mode |= (attr & FILE_ATTRIBUTE_READONLY) ? S_IREAD : S_IREAD|S_IWRITE; + mode |= (mode & (S_IREAD|S_IWRITE|S_IEXEC)) >> 3; + mode |= (mode & (S_IREAD|S_IWRITE|S_IEXEC)) >> 6; + + /* + * We don't construct a Tcl_StatBuf; we're using the info immediately. + */ + + TclNewObj(dictObj); +#define STORE_ELEM(name, value) StoreElementInDict(dictObj, name, value) + + STORE_ELEM("dev", Tcl_NewWideIntObj((long) dev)); + STORE_ELEM("ino", Tcl_NewWideIntObj((long long) inode)); + STORE_ELEM("nlink", Tcl_NewIntObj(nlink)); + STORE_ELEM("uid", Tcl_NewIntObj(0)); + STORE_ELEM("gid", Tcl_NewIntObj(0)); + STORE_ELEM("size", Tcl_NewWideIntObj((long long) size)); + STORE_ELEM("atime", Tcl_NewWideIntObj(atime)); + STORE_ELEM("mtime", Tcl_NewWideIntObj(mtime)); + STORE_ELEM("ctime", Tcl_NewWideIntObj(ctime)); + STORE_ELEM("mode", Tcl_NewWideIntObj(mode)); + + /* + * Windows only has files and directories, as far as we're concerned. + * Anything else and we definitely couldn't have got here anyway. + */ + if (attr & FILE_ATTRIBUTE_DIRECTORY) { + STORE_ELEM("type", Tcl_NewStringObj("directory", -1)); + } else { + STORE_ELEM("type", Tcl_NewStringObj("file", -1)); + } +#undef STORE_ELEM + + return dictObj; +} + +static int +FileGetOptionProc( + ClientData instanceData, /* The file state. */ + Tcl_Interp *interp, /* For error reporting. */ + const char *optionName, /* What option to read, or NULL for all. */ + Tcl_DString *dsPtr) /* Where to write the value read. */ +{ + FileInfo *infoPtr = (FileInfo *)instanceData; + int valid = 0; /* Flag if valid option parsed. */ + int len; + + if (optionName == NULL) { + len = 0; + valid = 1; + } else { + len = strlen(optionName); + } + + /* + * Get option -stat + * Option is readonly and returned by [fconfigure chan -stat] but not + * returned by [fconfigure chan] without explicit option name. + */ + + if ((len > 1) && (strncmp(optionName, "-stat", len) == 0)) { + Tcl_Obj *dictObj = StatOpenFile(infoPtr); + const char *dictContents; + Tcl_Size dictLength; + + if (dictObj == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't read file channel status: %s", + Tcl_PosixError(interp))); + return TCL_ERROR; + } + + /* + * Transfer dictionary to the DString. Note that we don't do this as + * an element as this is an option that can't be retrieved with a + * general probe. + */ + + dictContents = Tcl_GetStringFromObj(dictObj, &dictLength); + Tcl_DStringAppend(dsPtr, dictContents, dictLength); + Tcl_DecrRefCount(dictObj); + return TCL_OK; + } + + if (valid) { + return TCL_OK; + } + return Tcl_BadChannelOption(interp, optionName, + "stat"); +} + +/* + *---------------------------------------------------------------------- + * * TclpOpenFileChannel -- * * Open an File based channel on Unix systems. |