diff options
author | dgp <dgp@users.sourceforge.net> | 2018-03-15 14:23:18 (GMT) |
---|---|---|
committer | dgp <dgp@users.sourceforge.net> | 2018-03-15 14:23:18 (GMT) |
commit | be8b7d25f6ed27943242888bf395ea2aa50632ae (patch) | |
tree | e7faf7871cc0c0180df22b5903d708fba0a73a9c | |
parent | 0bef3861ff2e6a20bb908d6099a1b55ff80860e8 (diff) | |
parent | aa199edba612a516e6309290fb6dc4442a49a5ee (diff) | |
download | tcl-be8b7d25f6ed27943242888bf395ea2aa50632ae.zip tcl-be8b7d25f6ed27943242888bf395ea2aa50632ae.tar.gz tcl-be8b7d25f6ed27943242888bf395ea2aa50632ae.tar.bz2 |
merge 8.7
-rw-r--r-- | changes | 5 | ||||
-rw-r--r-- | doc/msgcat.n | 205 | ||||
-rw-r--r-- | generic/tclBasic.c | 1 | ||||
-rw-r--r-- | generic/tclCmdMZ.c | 47 | ||||
-rw-r--r-- | generic/tclCompCmdsSZ.c | 240 | ||||
-rw-r--r-- | generic/tclExecute.c | 109 | ||||
-rw-r--r-- | generic/tclInt.h | 29 | ||||
-rw-r--r-- | generic/tclOO.c | 249 | ||||
-rw-r--r-- | generic/tclOODefineCmds.c | 73 | ||||
-rw-r--r-- | generic/tclPipe.c | 78 | ||||
-rw-r--r-- | generic/tclProcess.c | 952 | ||||
-rw-r--r-- | generic/tclStringObj.c | 145 | ||||
-rw-r--r-- | generic/tclUtil.c | 255 | ||||
-rw-r--r-- | library/msgcat/msgcat.tcl | 300 | ||||
-rw-r--r-- | library/msgcat/pkgIndex.tcl | 4 | ||||
-rw-r--r-- | tests/coroutine.test | 2 | ||||
-rw-r--r-- | tests/foreach.test | 6 | ||||
-rw-r--r-- | tests/ioCmd.test | 4 | ||||
-rw-r--r-- | tests/ioTrans.test | 2 | ||||
-rw-r--r-- | tests/msgcat.test | 292 | ||||
-rw-r--r-- | tests/oo.test | 222 | ||||
-rw-r--r-- | tests/process.test | 31 | ||||
-rw-r--r-- | tests/string.test | 3 | ||||
-rw-r--r-- | unix/Makefile.in | 10 | ||||
-rw-r--r-- | win/Makefile.in | 5 | ||||
-rw-r--r-- | win/buildall.vc.bat | 4 | ||||
-rw-r--r-- | win/makefile.vc | 3 | ||||
-rw-r--r-- | win/tcl.dsp | 4 | ||||
-rw-r--r-- | win/tclWinPipe.c | 6 |
29 files changed, 2580 insertions, 706 deletions
@@ -8879,3 +8879,8 @@ in this changeset (new minor version) rather than bug fixes: 2017-09-02 (bug)[0e4d88] replace command, delete trace kills namespace (porter) --- Released 8.7a1, September 8, 2017 --- http://core.tcl.tk/tcl/ for details + +2018-03-12 (TIP 490) add oo support for msgcat => msgcat 1.7.0 (oehlmann) + +2018-03-12 (TIP 499) custom locale preference list (oehlmann) +=> msgcat 1.7.0 diff --git a/doc/msgcat.n b/doc/msgcat.n index 2fc1eee..9074725 100644 --- a/doc/msgcat.n +++ b/doc/msgcat.n @@ -11,9 +11,9 @@ .SH NAME msgcat \- Tcl message catalog .SH SYNOPSIS -\fBpackage require Tcl 8.5\fR +\fBpackage require Tcl 8.7\fR .sp -\fBpackage require msgcat 1.6\fR +\fBpackage require msgcat 1.7\fR .sp \fB::msgcat::mc \fIsrc-string\fR ?\fIarg arg ...\fR? .sp @@ -23,9 +23,15 @@ msgcat \- Tcl message catalog \fB::msgcat::mcexists\fR ?\fB-exactnamespace\fR? ?\fB-exactlocale\fR? \fIsrc-string\fR .VE "TIP 412" .sp +.VS "TIP 490" +\fB::msgcat::mcpackagenamespaceget\fR +.VE "TIP 490" +.sp \fB::msgcat::mclocale \fR?\fInewLocale\fR? .sp -\fB::msgcat::mcpreferences\fR +.VS "TIP 499" +\fB::msgcat::mcpreferences\fR ?\fIlocale preference\fR? ... +.VE "TIP 499" .sp .VS "TIP 412" \fB::msgcat::mcloadedlocales subcommand\fR ?\fIlocale\fR? @@ -50,6 +56,10 @@ msgcat \- Tcl message catalog .sp \fB::msgcat::mcforgetpackage\fR .VE "TIP 412" +.sp +.VS "TIP 499" +\fB::msgcat::mcutil subcommand\fR ?\fIlocale\fR? +.VS "TIP 499" .BE .SH DESCRIPTION .PP @@ -71,6 +81,11 @@ In \fBmsgcat\fR, there is a global locale initialized by the system locale of th Each package may decide to use the global locale or to use a package specific locale. .PP The global locale may be changed on demand, for example by a user initiated language change or within a multi user application like a web server. +.PP +.VS tip490 +Object oriented programming is supported by the use of a package namespace. +.VE tip490 +.PP .SH COMMANDS .TP \fB::msgcat::mc \fIsrc-string\fR ?\fIarg arg ...\fR? @@ -95,6 +110,17 @@ use the result. If an application is written for a single language in this fashion, then it is easy to add support for additional languages later simply by defining new message catalog entries. .RE +.VS "TIP 490" +.TP +\fB::msgcat::mcn \fInamespace\fR \fIsrc-string\fR ?\fIarg arg ...\fR? +. +Like \fB::msgcat::mc\fR, but with the message namespace specified as first argument. +.PP +.RS +\fBmcn\fR may be used for cases where the package namespace is not the namespace of the caller. +An example is shown within the description of the command \fB::msgcat::mcpackagenamespaceget\fR below. +.RE +.PP .TP \fB::msgcat::mcmax ?\fIsrc-string src-string ...\fR? . @@ -103,28 +129,68 @@ of the longest translated string. This is useful when designing localized GUIs, which may require that all buttons, for example, be a fixed width (which will be the width of the widest button). .TP -\fB::msgcat::mcexists\fR ?\fB-exactnamespace\fR? ?\fB-exactlocale\fR? \fIsrc-string\fR -. .VS "TIP 412" +\fB::msgcat::mcexists\fR ?\fB-exactnamespace\fR? ?\fB-exactlocale\fR? ?\fB-namespace\fR \fInamespace\fR? \fIsrc-string\fR +. Return true, if there is a translation for the given \fIsrc-string\fR. .PP .RS The search may be limited by the option \fB\-exactnamespace\fR to only check the current namespace and not any parent namespaces. .PP It may also be limited by the option \fB\-exactlocale\fR to only check the first prefered locale (e.g. first element returned by \fB::msgcat::mcpreferences\fR if global locale is used). -.RE +.PP .VE "TIP 412" +.VS "TIP 490" +An explicit package namespace may be specified by the option \fB-namespace\fR. +The namespace of the caller is used if not explicitly specified. +.RE +.PP +.VE "TIP 490" +.VS "TIP 490" +.TP +\fB::msgcat::mcpackagenamespaceget\fR +. +Return the package namespace of the caller. +This command handles all cases described in section \fBOBJECT ORIENTED PROGRAMMING\fR. +.PP +.RS +Example usage is a tooltip package, which saves the caller package namespace to update the translation each time the tooltip is shown: +.CS +proc ::tooltip::tooltip {widget message} { + ... + set messagenamespace [uplevel 1 {::msgcat::mcpackagenamespaceget}] + ... + bind $widget [list ::tooltip::show $widget $messagenamespace $message] +} + +proc ::tooltip::show {widget messagenamespace message} { + ... + set message [::msgcat::mcn $messagenamespace $message] + ... +} +.CE +.RE +.PP +.VE "TIP 490" .TP \fB::msgcat::mclocale \fR?\fInewLocale\fR? . -This function sets the locale to \fInewLocale\fR. If \fInewLocale\fR -is omitted, the current locale is returned, otherwise the current locale -is set to \fInewLocale\fR. msgcat stores and compares the locale in a +If \fInewLocale\fR is omitted, the current locale is returned, otherwise the current locale +is set to \fInewLocale\fR. +.PP +.RS +If the new locale is set to \fInewLocale\fR, the corresponding preferences are calculated and set. +For example, if the current locale is en_US_funky, then \fB::msgcat::mcpreferences\fR returns \fB{en_us_funky en_us en {}}\fR. +.PP +The same result may be acheved by \fB::msgcat::mcpreferences\fR {*}[\fB::msgcat::mcutil getpreferences\fR \fInewLocale\fR]. +.PP +The current locale is always the first element of the list returned by \fBmcpreferences\fR. +.PP +msgcat stores and compares the locale in a case-insensitive manner, and returns locales in lowercase. The initial locale is determined by the locale specified in the user's environment. See \fBLOCALE SPECIFICATION\fR below for a description of the locale string format. -.RS .PP .VS "TIP 412" If the locale is set, the preference list of locales is evaluated. @@ -132,16 +198,26 @@ Locales in this list are loaded now, if not jet loaded. .VE "TIP 412" .RE .TP -\fB::msgcat::mcpreferences\fR +\fB::msgcat::mcpreferences\fR ?\fIlocale preference\fR? ... . -Returns an ordered list of the locales preferred by -the user, based on the user's language specification. -The list is ordered from most specific to least -preference. The list is derived from the current -locale set in msgcat by \fB::msgcat::mclocale\fR, and -cannot be set independently. For example, if the -current locale is en_US_funky, then \fB::msgcat::mcpreferences\fR -returns \fB{en_us_funky en_us en {}}\fR. +Without arguments, returns an ordered list of the locales preferred by +the user. +The list is ordered from most specific to least preference. +.PP +.VS "TIP 499" +.RS +A set of locale preferences may be given to set the list of locale preferences. +The current locale is also set, which is the first element of the locale preferences list. +.PP +Locale preferences are loaded now, if not jet loaded. +.PP +As an example, the user may prefer French or English text. This may be configured by: +.CS +::msgcat::mcpreferences fr en {} +.CE +.RE +.PP +.VS "TIP 499" .TP \fB::msgcat:mcloadedlocales subcommand\fR ?\fIlocale\fR? . @@ -232,6 +308,22 @@ Note that this routine is only called if the concerned package did not set a pac The calling package clears all its state within the \fBmsgcat\fR package including all settings and translations. .VE "TIP 412" .PP +.VS "TIP 499" +.TP +\fB::msgcat::mcutil getpreferences\fR \fIlocale\fR +. +Return the preferences list of the given locale as described in section \fBLOCALE SPECIFICATION\fR. +An example is the composition of a preference list for the bilingual region "Biel/Bienne" as a concatenation of swiss german and swiss french: +.CS +% concat [lrange [msgcat::mcutil getpreferences fr_CH] 0 end-1] [msgcat::mcutil getpreferences de_CH] +fr_ch fr de_ch de {} +.CE +.TP +\fB::msgcat::mcutil getsystemlocale\fR +. +The system locale is returned as described by the section \fBLOCALE SPECIFICATION\fR. +.VE "TIP 499" +.PP .SH "LOCALE SPECIFICATION" .PP The locale is specified to \fBmsgcat\fR by a locale string @@ -437,7 +529,7 @@ formatting substitution is done directly. # human-oriented versions by \fBmsgcat::mcset\fR .CE .VS "TIP 412" -.SH Package private locale +.SH "PACKAGE PRIVATE LOCALE" .PP A package using \fBmsgcat\fR may choose to use its own package private locale and its own set of loaded locales, independent to the global @@ -461,10 +553,22 @@ This command may cause the load of locales. . Return the package private locale or the global locale, if no package private locale is set. .TP -\fB::msgcat::mcpackagelocale preferences\fR +\fB::msgcat::mcpackagelocale preferences\fR ?\fIlocale preference\fR? ... . -Return the package private preferences or the global preferences, +With no parameters, return the package private preferences or the global preferences, if no package private locale is set. +The package locale state (set or not) is not changed (in contrast to the command \fB::msgcat::mcpackagelocale set\fR). +.PP +.RS +.VS "TIP 499" +If a set of locale preferences is given, it is set as package locale preference list. +The package locale is set to the first element of the preference list. +A package locale is activated, if it was not set so far. +.PP +Locale preferences are loaded now for the package, if not jet loaded. +.VE "TIP 499" +.RE +.PP .TP \fB::msgcat::mcpackagelocale loaded\fR . @@ -488,7 +592,7 @@ Returns true, if the given locale is loaded for the package. . Clear any loaded locales of the package not present in the package preferences. .PP -.SH Changing package options +.SH "CHANGING PACKAGE OPTIONS" .PP Each package using msgcat has a set of options within \fBmsgcat\fR. The package options are described in the next sectionPackage options. @@ -563,7 +667,7 @@ A generic unknown handler is used if set to the empty string. This consists in r See section \fBcallback invocation\fR below. The appended arguments are identical to \fB::msgcat::mcunknown\fR. .RE -.SS Callback invocation +.SH "Callback invocation" A package may decide to register one or multiple callbacks, as described above. .PP Callbacks are invoked, if: @@ -577,7 +681,54 @@ Callbacks are invoked, if: If a called routine fails with an error, the \fBbgerror\fR routine for the interpreter is invoked after command completion. Only exception is the callback \fBunknowncmd\fR, where an error causes the invoking \fBmc\fR-command to fail with that error. .PP -.SS Examples +.VS tip490 +.SH "OBJECT ORIENTED PROGRAMMING" +\fBmsgcat\fR supports packages implemented by object oriented programming. +Objects and classes should be defined within a package namespace. +.PP +There are 3 supported cases where package namespace sensitive commands of msgcat (\fBmc\fR, \fBmcexists\fR, \fBmcpackagelocale\fR, \fBmcforgetpackage\fR, \fBmcpackagenamespaceget\fR, \fBmcpackageconfig\fR, \fBmcset\fR and \fBmcmset\fR) may be called: +.PP +.TP +\fB1) In class definition script\fR +. +\fBmsgcat\fR command is called within a class definition script. +.CS +namespace eval ::N2 { + mcload $dir/msgs + oo::class create C1 {puts [mc Hi!]} +} +.CE +.PP +.TP +\fB2) method defined in a class\fR +. +\fBmsgcat\fR command is called from a method in an object and the method is defined in a class. +.CS +namespace eval ::N3Class { + mcload $dir/msgs + oo::class create C1 + oo::define C1 method m1 { + puts [mc Hi!] + } +} +.CE +.PP +.TP +\fB3) method defined in a classless object\fR +. +\fBmsgcat\fR command is called from a method of a classless object. +.CS +namespace eval ::N4 { + mcload $dir/msgs + oo::object create O1 + oo::objdefine O1 method m1 {} { + puts [mc Hi!] + } +} +.CE +.PP +.VE tip490 +.SH EXAMPLES Packages which display a GUI may update their widgets when the global locale changes. To register to a callback, use: .CS @@ -643,9 +794,9 @@ proc ::tcl::clock::LocalizeFormat { locale format } { .PP The message catalog code was developed by Mark Harrison. .SH "SEE ALSO" -format(n), scan(n), namespace(n), package(n) +format(n), scan(n), namespace(n), package(n), oo::class(n), oo::object .SH KEYWORDS -internationalization, i18n, localization, l10n, message, text, translation +internationalization, i18n, localization, l10n, message, text, translation, class, object .\" Local Variables: .\" mode: nroff .\" End: diff --git a/generic/tclBasic.c b/generic/tclBasic.c index f9cf50d..73a20d8 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -819,6 +819,7 @@ Tcl_CreateInterp(void) TclInitNamespaceCmd(interp); TclInitStringCmd(interp); TclInitPrefixCmd(interp); + TclInitProcessCmd(interp); /* * Register "clock" subcommands. These *do* go through diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 1a56056..c9474ca 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -2306,42 +2306,50 @@ StringRplcCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_UniChar *ustring; - int first, last, length; + int first, last, length, end; if (objc < 4 || objc > 5) { Tcl_WrongNumArgs(interp, 1, objv, "string first last ?string?"); return TCL_ERROR; } - ustring = Tcl_GetUnicodeFromObj(objv[1], &length); - length--; + length = Tcl_GetCharLength(objv[1]); + end = length - 1; - if (TclGetIntForIndexM(interp, objv[2], length, &first) != TCL_OK || - TclGetIntForIndexM(interp, objv[3], length, &last) != TCL_OK){ + if (TclGetIntForIndexM(interp, objv[2], end, &first) != TCL_OK || + TclGetIntForIndexM(interp, objv[3], end, &last) != TCL_OK){ return TCL_ERROR; } - if ((last < first) || (last < 0) || (first > length)) { + /* + * The following test screens out most empty substrings as + * candidates for replacement. When they are detected, no + * replacement is done, and the result is the original string, + */ + if ((last < 0) || /* Range ends before start of string */ + (first > end) || /* Range begins after end of string */ + (last < first)) { /* Range begins after it starts */ + + /* + * BUT!!! when (end < 0) -- an empty original string -- we can + * have (first <= end < 0 <= last) and an empty string is permitted + * to be replaced. + */ Tcl_SetObjResult(interp, objv[1]); } else { Tcl_Obj *resultPtr; - ustring = Tcl_GetUnicodeFromObj(objv[1], &length); - length--; - if (first < 0) { first = 0; } - - resultPtr = Tcl_NewUnicodeObj(ustring, first); - if (objc == 5) { - Tcl_AppendObjToObj(resultPtr, objv[4]); - } - if (last < length) { - Tcl_AppendUnicodeToObj(resultPtr, ustring + last + 1, - length - last); + if (last > end) { + last = end; } + + resultPtr = TclStringReplace(interp, objv[1], first, + last + 1 - first, (objc == 5) ? objv[4] : NULL, + TCL_STRING_IN_PLACE); + Tcl_SetObjResult(interp, resultPtr); } return TCL_OK; @@ -3211,8 +3219,7 @@ StringTrimCmd( } string1 = TclGetStringFromObj(objv[1], &length1); - triml = TclTrimLeft(string1, length1, string2, length2); - trimr = TclTrimRight(string1 + triml, length1 - triml, string2, length2); + triml = TclTrim(string1, length1, string2, length2, &trimr); Tcl_SetObjResult(interp, Tcl_NewStringObj(string1 + triml, length1 - triml - trimr)); diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 79c5c78..cf088bb 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -995,147 +995,197 @@ TclCompileStringReplaceCmd( * compiled. */ CompileEnv *envPtr) /* Holds the resulting instructions. */ { - Tcl_Token *tokenPtr, *valueTokenPtr, *replacementTokenPtr = NULL; + Tcl_Token *tokenPtr, *valueTokenPtr; DefineLineInformation; /* TIP #280 */ - int idx1, idx2; + int first, last; if (parsePtr->numWords < 4 || parsePtr->numWords > 5) { return TCL_ERROR; } + + /* Bytecode to compute/push string argument being replaced */ valueTokenPtr = TokenAfter(parsePtr->tokenPtr); - if (parsePtr->numWords == 5) { - tokenPtr = TokenAfter(valueTokenPtr); - tokenPtr = TokenAfter(tokenPtr); - replacementTokenPtr = TokenAfter(tokenPtr); - } + CompileWord(envPtr, valueTokenPtr, interp, 1); + /* + * Check for first index known and useful at compile time. + */ tokenPtr = TokenAfter(valueTokenPtr); - if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_START, TCL_INDEX_AFTER, - &idx1) != TCL_OK) { + if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_AFTER, + &first) != TCL_OK) { goto genericReplace; } + /* - * Token parsed as an index value. Indices before the string are - * treated as index of start of string. + * Check for last index known and useful at compile time. */ - tokenPtr = TokenAfter(tokenPtr); - if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_END, - &idx2) != TCL_OK) { + if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_AFTER, + &last) != TCL_OK) { goto genericReplace; } - /* - * Token parsed as an index value. Indices after the string are - * treated as index of end of string. - */ -/* TODO...... */ - /* - * We handle these replacements specially: first character (where - * idx1=idx2=0) and last character (where idx1=idx2=TCL_INDEX_END). Anything - * else and the semantics get rather screwy. + /* + * [string replace] is an odd bird. For many arguments it is + * a conventional substring replacer. However it also goes out + * of its way to become a no-op for many cases where it would be + * replacing an empty substring. Precisely, it is a no-op when * - * TODO: These seem to be very narrow cases. They are not even - * covered by the test suite, and any programming that ends up - * here could have been coded by the programmer using [string range] - * and [string cat]. [*] Not clear at all to me that the bytecode - * generated here is worthwhile. + * (last < first) OR + * (last < 0) OR + * (end < first) * - * [*] Except for the empty string exceptions. UGGGGHHHH. + * For some compile-time values we can detect these cases, and + * compile direct to bytecode implementing the no-op. */ - if (idx1 == 0 && idx2 == 0) { - int notEq, end; + if ((last == TCL_INDEX_BEFORE) /* Know (last < 0) */ + || (first == TCL_INDEX_AFTER) /* Know (first > end) */ /* - * Just working with the first character. + * Tricky to determine when runtime (last < first) can be + * certainly known based on the encoded values. Consider the + * cases... + * + * (first <= TCL_INDEX_END) && + * (last == TCL_INDEX_AFTER) => cannot tell REJECT + * (last <= TCL_INDEX END) && (last < first) => ACCEPT + * else => cannot tell REJECT */ - - CompileWord(envPtr, valueTokenPtr, interp, 1); - if (replacementTokenPtr == NULL) { - /* Drop first */ - OP44( STR_RANGE_IMM, 1, TCL_INDEX_END); - return TCL_OK; - } - /* Replace first */ - CompileWord(envPtr, replacementTokenPtr, interp, 4); - + || ((first <= TCL_INDEX_END) && (last <= TCL_INDEX_END) + && (last < first)) /* Know (last < first) */ /* - * NOTE: The following tower of bullshit is present because - * [string replace] was boneheadedly defined not to replace - * empty strings, so we actually have to detect the empty - * string case and treat it differently. + * (first == TCL_INDEX_BEFORE) && + * (last == TCL_INDEX_AFTER) => (first < last) REJECT + * (last <= TCL_INDEX_END) => cannot tell REJECT + * else => (first < last) REJECT + * + * else [[first >= TCL_INDEX_START]] && + * (last == TCL_INDEX_AFTER) => cannot tell REJECT + * (last <= TCL_INDEX_END) => cannot tell REJECT + * else [[last >= TCL_INDEX START]] && (last < first) => ACCEPT */ - - OP4( OVER, 1); - PUSH( ""); - OP( STR_EQ); - JUMP1( JUMP_FALSE, notEq); - OP( POP); - JUMP1( JUMP, end); - FIXJUMP1(notEq); - TclAdjustStackDepth(1, envPtr); - OP4( REVERSE, 2); - OP44( STR_RANGE_IMM, 1, TCL_INDEX_END); - OP1( STR_CONCAT1, 2); - FIXJUMP1(end); + || ((first >= TCL_INDEX_START) && (last >= TCL_INDEX_START) + && (last < first))) { /* Know (last < first) */ + if (parsePtr->numWords == 5) { + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 4); + OP( POP); /* Pop newString */ + } + /* Original string argument now on TOS as result */ return TCL_OK; + } - } else if (idx1 == TCL_INDEX_END && idx2 == TCL_INDEX_END) { - int notEq, end; - - /* - * Just working with the last character. - */ + if (parsePtr->numWords == 5) { + /* + * When we have a string replacement, we have to take care about + * not replacing empty substrings that [string replace] promises + * not to replace + * + * The remaining index values might be suitable for conventional + * string replacement, but only if they cannot possibly meet the + * conditions described above at runtime. If there's a chance they + * might, we would have to emit bytecode to check and at that point + * we're paying more in bytecode execution time than would make + * things worthwhile. Trouble is we are very limited in + * how much we can detect that at compile time. After decoding, + * we need, first: + * + * (first <= end) + * + * The encoded indices (first <= TCL_INDEX END) and + * (first == TCL_INDEX_BEFORE) always meets this condition, but + * any other encoded first index has some list for which it fails. + * + * We also need, second: + * + * (last >= 0) + * + * The encoded indices (last >= TCL_INDEX_START) and + * (last == TCL_INDEX_AFTER) always meet this condition but any + * other encoded last index has some list for which it fails. + * + * Finally we need, third: + * + * (first <= last) + * + * Considered in combination with the constraints we already have, + * we see that we can proceed when (first == TCL_INDEX_BEFORE) + * or (last == TCL_INDEX_AFTER). These also permit simplification + * of the prefix|replace|suffix construction. The other constraints, + * though, interfere with getting a guarantee that first <= last. + */ - CompileWord(envPtr, valueTokenPtr, interp, 1); - if (replacementTokenPtr == NULL) { - /* Drop last */ - OP44( STR_RANGE_IMM, 0, TCL_INDEX_END-1); - return TCL_OK; + if ((first == TCL_INDEX_BEFORE) && (last >= TCL_INDEX_START)) { + /* empty prefix */ + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 4); + OP4( REVERSE, 2); + if (last == TCL_INDEX_AFTER) { + OP( POP); /* Pop original */ + } else { + OP44( STR_RANGE_IMM, last + 1, TCL_INDEX_END); + OP1( STR_CONCAT1, 2); } - /* Replace last */ - CompileWord(envPtr, replacementTokenPtr, interp, 4); - - /* More bullshit; see NOTE above. */ + return TCL_OK; + } - OP4( OVER, 1); - PUSH( ""); - OP( STR_EQ); - JUMP1( JUMP_FALSE, notEq); - OP( POP); - JUMP1( JUMP, end); - FIXJUMP1(notEq); - TclAdjustStackDepth(1, envPtr); - OP4( REVERSE, 2); - OP44( STR_RANGE_IMM, 0, TCL_INDEX_END-1); - OP4( REVERSE, 2); + if ((last == TCL_INDEX_AFTER) && (first <= TCL_INDEX_END)) { + OP44( STR_RANGE_IMM, 0, first-1); + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 4); OP1( STR_CONCAT1, 2); - FIXJUMP1(end); return TCL_OK; + } + + /* FLOW THROUGH TO genericReplace */ } else { - /* - * Need to process indices at runtime. This could be because the - * indices are not constants, or because we need to resolve them to - * absolute indices to work out if a replacement is going to happen. - * In any case, to runtime it is. + /* + * When we have no replacement string to worry about, we may + * have more luck, because the forbidden empty string replacements + * are harmless when they are replaced by another empty string. */ + if ((first == TCL_INDEX_BEFORE) || (first == TCL_INDEX_START)) { + /* empty prefix - build suffix only */ + + if ((last == TCL_INDEX_END) || (last == TCL_INDEX_AFTER)) { + /* empty suffix too => empty result */ + OP( POP); /* Pop original */ + PUSH ( ""); + return TCL_OK; + } + OP44( STR_RANGE_IMM, last + 1, TCL_INDEX_END); + return TCL_OK; + } else { + if ((last == TCL_INDEX_END) || (last == TCL_INDEX_AFTER)) { + /* empty suffix - build prefix only */ + OP44( STR_RANGE_IMM, 0, first-1); + return TCL_OK; + } + OP( DUP); + OP44( STR_RANGE_IMM, 0, first-1); + OP4( REVERSE, 2); + OP44( STR_RANGE_IMM, last + 1, TCL_INDEX_END); + OP1( STR_CONCAT1, 2); + return TCL_OK; + } + } + genericReplace: - CompileWord(envPtr, valueTokenPtr, interp, 1); tokenPtr = TokenAfter(valueTokenPtr); CompileWord(envPtr, tokenPtr, interp, 2); tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, 3); - if (replacementTokenPtr != NULL) { - CompileWord(envPtr, replacementTokenPtr, interp, 4); + if (parsePtr->numWords == 5) { + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 4); } else { PUSH( ""); } OP( STR_REPLACE); return TCL_OK; - } } int diff --git a/generic/tclExecute.c b/generic/tclExecute.c index abe0297..1d35932 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -5430,18 +5430,18 @@ TEBCresume( { Tcl_UniChar *ustring1, *ustring2, *ustring3, *end, *p; - int length3; + int length3, endIdx; Tcl_Obj *value3Ptr; case INST_STR_REPLACE: value3Ptr = POP_OBJECT(); valuePtr = OBJ_AT_DEPTH(2); - length = Tcl_GetCharLength(valuePtr) - 1; + endIdx = Tcl_GetCharLength(valuePtr) - 1; TRACE(("\"%.20s\" %s %s \"%.20s\" => ", O2S(valuePtr), O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), O2S(value3Ptr))); - if (TclGetIntForIndexM(interp, OBJ_UNDER_TOS, length, + if (TclGetIntForIndexM(interp, OBJ_UNDER_TOS, endIdx, &fromIdx) != TCL_OK - || TclGetIntForIndexM(interp, OBJ_AT_TOS, length, + || TclGetIntForIndexM(interp, OBJ_AT_TOS, endIdx, &toIdx) != TCL_OK) { TclDecrRefCount(value3Ptr); TRACE_ERROR(interp); @@ -5451,103 +5451,33 @@ TEBCresume( (void) POP_OBJECT(); TclDecrRefCount(OBJ_AT_TOS); (void) POP_OBJECT(); - if (fromIdx < 0) { - fromIdx = 0; - } - if (fromIdx > toIdx || fromIdx > length) { + if ((toIdx < 0) || + (fromIdx > endIdx) || + (toIdx < fromIdx)) { TRACE_APPEND(("\"%.30s\"\n", O2S(valuePtr))); TclDecrRefCount(value3Ptr); NEXT_INST_F(1, 0, 0); } - if (toIdx > length) { - toIdx = length; + if (fromIdx < 0) { + fromIdx = 0; + } + + if (toIdx > endIdx) { + toIdx = endIdx; } - if (fromIdx == 0 && toIdx == length) { + if (fromIdx == 0 && toIdx == endIdx) { TclDecrRefCount(OBJ_AT_TOS); OBJ_AT_TOS = value3Ptr; TRACE_APPEND(("\"%.30s\"\n", O2S(value3Ptr))); NEXT_INST_F(1, 0, 0); } - length3 = Tcl_GetCharLength(value3Ptr); - - /* - * See if we can splice in place. This happens when the number of - * characters being replaced is the same as the number of characters - * in the string to be inserted. - */ - - if (length3 - 1 == toIdx - fromIdx) { - unsigned char *bytes1, *bytes2; + objResultPtr = TclStringReplace(interp, valuePtr, fromIdx, + toIdx - fromIdx + 1, value3Ptr, TCL_STRING_IN_PLACE); - if (Tcl_IsShared(valuePtr)) { - objResultPtr = Tcl_DuplicateObj(valuePtr); - } else { - objResultPtr = valuePtr; - } - if (TclIsPureByteArray(objResultPtr) - && TclIsPureByteArray(value3Ptr)) { - bytes1 = Tcl_GetByteArrayFromObj(objResultPtr, NULL); - bytes2 = Tcl_GetByteArrayFromObj(value3Ptr, NULL); - memcpy(bytes1 + fromIdx, bytes2, length3); - } else { - ustring1 = Tcl_GetUnicodeFromObj(objResultPtr, NULL); - ustring2 = Tcl_GetUnicodeFromObj(value3Ptr, NULL); - memcpy(ustring1 + fromIdx, ustring2, - length3 * sizeof(Tcl_UniChar)); - } - Tcl_InvalidateStringRep(objResultPtr); - TclDecrRefCount(value3Ptr); - TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); - if (objResultPtr == valuePtr) { - NEXT_INST_F(1, 0, 0); - } else { - NEXT_INST_F(1, 1, 1); - } - } - - /* - * Get the unicode representation; this is where we guarantee to lose - * bytearrays. - */ - - ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length); - length--; - - /* - * Remove substring using copying. - */ - - objResultPtr = NULL; - if (fromIdx > 0) { - objResultPtr = Tcl_NewUnicodeObj(ustring1, fromIdx); - } - if (length3 > 0) { - if (objResultPtr) { - Tcl_AppendObjToObj(objResultPtr, value3Ptr); - } else if (Tcl_IsShared(value3Ptr)) { - objResultPtr = Tcl_DuplicateObj(value3Ptr); - } else { - objResultPtr = value3Ptr; - } - } - if (toIdx < length) { - if (objResultPtr) { - Tcl_AppendUnicodeToObj(objResultPtr, ustring1 + toIdx + 1, - length - toIdx); - } else { - objResultPtr = Tcl_NewUnicodeObj(ustring1 + toIdx + 1, - length - toIdx); - } - } - if (objResultPtr == NULL) { - /* This has to be the case [string replace $s 0 end {}] */ - /* which has result {} which is same as value3Ptr. */ - objResultPtr = value3Ptr; - } if (objResultPtr == value3Ptr) { /* See [Bug 82e7f67325] */ TclDecrRefCount(OBJ_AT_TOS); @@ -5722,12 +5652,7 @@ TEBCresume( value2Ptr = OBJ_AT_TOS; /* TrimSet */ string2 = TclGetStringFromObj(value2Ptr, &length2); string1 = TclGetStringFromObj(valuePtr, &length); - trim1 = TclTrimLeft(string1, length, string2, length2); - if (trim1 < length) { - trim2 = TclTrimRight(string1, length, string2, length2); - } else { - trim2 = 0; - } + trim1 = TclTrim(string1, length, string2, length2, &trim2); createTrimmedString: /* * Careful here; trim set often contains non-ASCII characters so we diff --git a/generic/tclInt.h b/generic/tclInt.h index 0dd129b..a7e4f0a 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3200,6 +3200,8 @@ MODULE_SCOPE void TclSubstParse(Tcl_Interp *interp, const char *bytes, MODULE_SCOPE int TclSubstTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr, int count, int *tokensLeftPtr, int line, int *clNextOuter, const char *outerScript); +MODULE_SCOPE int TclTrim(const char *bytes, int numBytes, + const char *trim, int numTrim, int *trimRight); MODULE_SCOPE int TclTrimLeft(const char *bytes, int numBytes, const char *trim, int numTrim); MODULE_SCOPE int TclTrimRight(const char *bytes, int numBytes, @@ -4006,6 +4008,9 @@ MODULE_SCOPE int TclStringLast(Tcl_Obj *needle, Tcl_Obj *haystack, int last); MODULE_SCOPE Tcl_Obj * TclStringRepeat(Tcl_Interp *interp, Tcl_Obj *objPtr, int count, int flags); +MODULE_SCOPE Tcl_Obj * TclStringReplace(Tcl_Interp *interp, Tcl_Obj *objPtr, + int first, int count, Tcl_Obj *insertPtr, + int flags); MODULE_SCOPE Tcl_Obj * TclStringReverse(Tcl_Obj *objPtr, int flags); /* Flag values for the [string] ensemble functions. */ @@ -4069,6 +4074,30 @@ MODULE_SCOPE TCL_HASH_TYPE TclHashObjKey(Tcl_HashTable *tablePtr, void *keyPtr); MODULE_SCOPE int TclFullFinalizationRequested(void); /* + * TIP #462. + */ + +/* + * The following enum values give the status of a spawned process. + */ + +typedef enum TclProcessWaitStatus { + TCL_PROCESS_ERROR = -1, /* Error waiting for process to exit */ + TCL_PROCESS_UNCHANGED = 0, /* No change since the last call. */ + TCL_PROCESS_EXITED = 1, /* Process has exited. */ + TCL_PROCESS_SIGNALED = 2, /* Child killed because of a signal. */ + TCL_PROCESS_STOPPED = 3, /* Child suspended because of a signal. */ + TCL_PROCESS_UNKNOWN_STATUS = 4 + /* Child wait status didn't make sense. */ +} TclProcessWaitStatus; + +MODULE_SCOPE Tcl_Command TclInitProcessCmd(Tcl_Interp *interp); +MODULE_SCOPE void TclProcessCreated(Tcl_Pid pid); +MODULE_SCOPE TclProcessWaitStatus TclProcessWait(Tcl_Pid pid, int options, + int *codePtr, Tcl_Obj **msgObjPtr, + Tcl_Obj **errorObjPtr); + +/* * Utility routines for encoding index values as integers. Used by both * some of the command compilers and by [lsort] and [lsearch]. */ diff --git a/generic/tclOO.c b/generic/tclOO.c index dcf48ef..d68131d 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -511,61 +511,53 @@ InitClassSystemRoots( Class fakeCls; Object fakeObject; - /* - * Stand up a phony class for bootstrapping. - */ - + /* Stand up a phony class for bootstrapping. */ fPtr->objectCls = &fakeCls; - - /* - * Referenced in AllocClass to increment the refCount. - */ - + /* referenced in AllocClass to increment the refCount. */ fakeCls.thisPtr = &fakeObject; fPtr->objectCls = AllocClass(interp, AllocObject(interp, "object", (Namespace *)fPtr->ooNs, NULL)); - fPtr->classCls = AllocClass(interp, - AllocObject(interp, "class", (Namespace *)fPtr->ooNs, NULL)); - - /* - * Rewire bootstrapped objects. - */ - - fPtr->objectCls->thisPtr->selfCls = fPtr->classCls; - fPtr->classCls->thisPtr->selfCls = fPtr->classCls; - + /* Corresponding TclOODecrRefCount in KillFoudation */ AddRef(fPtr->objectCls->thisPtr); - AddRef(fPtr->classCls->thisPtr); - AddRef(fPtr->classCls->thisPtr->selfCls->thisPtr); - AddRef(fPtr->objectCls->thisPtr->selfCls->thisPtr); - /* - * Special initialization for the primordial objects. - */ + /* This is why it is unnecessary in this routine to replace the + * incremented reference count of fPtr->objectCls that was swallowed by + * fakeObject. */ + fPtr->objectCls->superclasses.num = 0; + ckfree(fPtr->objectCls->superclasses.list); + fPtr->objectCls->superclasses.list = NULL; + /* special initialization for the primordial objects */ fPtr->objectCls->thisPtr->flags |= ROOT_OBJECT; fPtr->objectCls->flags |= ROOT_OBJECT; + fPtr->classCls = AllocClass(interp, + AllocObject(interp, "class", (Namespace *)fPtr->ooNs, NULL)); + /* Corresponding TclOODecrRefCount in KillFoudation */ + AddRef(fPtr->classCls->thisPtr); + /* - * This is why it is unnecessary in this routine to make up for the - * incremented reference count of fPtr->objectCls that was sallwed by - * fakeObject. + * Increment reference counts for each reference because these + * relationships can be dynamically changed. + * + * Corresponding TclOODecrRefCount for all incremented refcounts is in + * KillFoundation. */ - fPtr->objectCls->superclasses.num = 0; - ckfree(fPtr->objectCls->superclasses.list); - fPtr->objectCls->superclasses.list = NULL; + /* Rewire bootstrapped objects. */ + fPtr->objectCls->thisPtr->selfCls = fPtr->classCls; + AddRef(fPtr->classCls->thisPtr); + TclOOAddToInstances(fPtr->objectCls->thisPtr, fPtr->classCls); + + fPtr->classCls->thisPtr->selfCls = fPtr->classCls; + AddRef(fPtr->classCls->thisPtr); + TclOOAddToInstances(fPtr->classCls->thisPtr, fPtr->classCls); fPtr->classCls->thisPtr->flags |= ROOT_CLASS; fPtr->classCls->flags |= ROOT_CLASS; - /* - * Standard initialization for new Objects. - */ - - TclOOAddToInstances(fPtr->objectCls->thisPtr, fPtr->classCls); - TclOOAddToInstances(fPtr->classCls->thisPtr, fPtr->classCls); + /* Standard initialization for new Objects */ TclOOAddToSubclasses(fPtr->classCls, fPtr->objectCls); /* @@ -632,20 +624,14 @@ KillFoundation( { Foundation *fPtr = GetFoundation(interp); - /* - * Crude mechanism to avoid leaking the Object struct of the - * foundation components oo::object and oo::class - * - * Should probably be replaced with something more elegantly designed. - */ - while (TclOODecrRefCount(fPtr->objectCls->thisPtr) == 0) {}; - while (TclOODecrRefCount(fPtr->classCls->thisPtr) == 0) {}; - TclDecrRefCount(fPtr->unknownMethodNameObj); TclDecrRefCount(fPtr->constructorName); TclDecrRefCount(fPtr->destructorName); TclDecrRefCount(fPtr->clonedName); TclDecrRefCount(fPtr->defineName); + TclOODecrRefCount(fPtr->objectCls->thisPtr); + TclOODecrRefCount(fPtr->classCls->thisPtr); + ckfree(fPtr); } @@ -729,12 +715,16 @@ AllocObject( Tcl_ResetResult(interp); } + + configNamespace: + + ((Namespace *)oPtr->namespacePtr)->refCount++; + /* * Make the namespace know about the helper commands. This grants access * to the [self] and [next] commands. */ - configNamespace: if (fPtr->helpersNs != NULL) { TclSetNsPath((Namespace *) oPtr->namespacePtr, 1, &fPtr->helpersNs); } @@ -901,10 +891,9 @@ ObjectRenamedTrace( /* * ---------------------------------------------------------------------- * - * DeleteDescendants, ReleaseClassContents -- + * DeleteDescendants -- * - * Tear down the special class data structure, including deleting all - * dependent classes and objects. + * Delete all descendants of a particular class. * * ---------------------------------------------------------------------- */ @@ -916,44 +905,55 @@ DeleteDescendants( { Class *clsPtr = oPtr->classPtr, *subclassPtr, *mixinSubclassPtr; Object *instancePtr; - int i; /* * Squelch classes that this class has been mixed into. */ - FOREACH(mixinSubclassPtr, clsPtr->mixinSubs) { - /* - * This condition also covers the case where mixinSubclassPtr == - * clsPtr - */ - - if (!Deleted(mixinSubclassPtr->thisPtr)) { - Tcl_DeleteCommandFromToken(interp, - mixinSubclassPtr->thisPtr->command); + if (clsPtr->mixinSubs.num > 0) { + while (clsPtr->mixinSubs.num > 0) { + mixinSubclassPtr = clsPtr->mixinSubs.list[clsPtr->mixinSubs.num-1]; + /* This condition also covers the case where mixinSubclassPtr == + * clsPtr + */ + if (!Deleted(mixinSubclassPtr->thisPtr)) { + Tcl_DeleteCommandFromToken(interp, + mixinSubclassPtr->thisPtr->command); + } + TclOORemoveFromMixinSubs(mixinSubclassPtr, clsPtr); } - i -= TclOORemoveFromMixinSubs(mixinSubclassPtr, clsPtr); - TclOODecrRefCount(mixinSubclassPtr->thisPtr); + } + if (clsPtr->mixinSubs.size > 0) { + ckfree(clsPtr->mixinSubs.list); + clsPtr->mixinSubs.size = 0; } /* * Squelch subclasses of this class. */ - FOREACH(subclassPtr, clsPtr->subclasses) { - if (!Deleted(subclassPtr->thisPtr) && !IsRoot(subclassPtr)) { - Tcl_DeleteCommandFromToken(interp, subclassPtr->thisPtr->command); + if (clsPtr->subclasses.num > 0) { + while (clsPtr->subclasses.num > 0) { + subclassPtr = clsPtr->subclasses.list[clsPtr->subclasses.num-1]; + if (!Deleted(subclassPtr->thisPtr) && !IsRoot(subclassPtr)) { + Tcl_DeleteCommandFromToken(interp, subclassPtr->thisPtr->command); + } + TclOORemoveFromSubclasses(subclassPtr, clsPtr); } - i -= TclOORemoveFromSubclasses(subclassPtr, clsPtr); - TclOODecrRefCount(subclassPtr->thisPtr); + } + if (clsPtr->subclasses.size > 0) { + ckfree(clsPtr->subclasses.list); + clsPtr->subclasses.list = NULL; + clsPtr->subclasses.size = 0; } /* * Squelch instances of this class (includes objects we're mixed into). */ - if (!IsRootClass(oPtr)) { - FOREACH(instancePtr, clsPtr->instances) { + if (clsPtr->instances.num > 0) { + while (clsPtr->instances.num > 0) { + instancePtr = clsPtr->instances.list[clsPtr->instances.num-1]; /* * This condition also covers the case where instancePtr == oPtr */ @@ -961,10 +961,26 @@ DeleteDescendants( if (!Deleted(instancePtr) && !IsRoot(instancePtr)) { Tcl_DeleteCommandFromToken(interp, instancePtr->command); } - i -= TclOORemoveFromInstances(instancePtr, clsPtr); + TclOORemoveFromInstances(instancePtr, clsPtr); } } + if (clsPtr->instances.size > 0) { + ckfree(clsPtr->instances.list); + clsPtr->instances.list = NULL; + clsPtr->instances.size = 0; + } } + +/* + * ---------------------------------------------------------------------- + * + * ReleaseClassContents -- + * + * Tear down the special class data structure, including deleting all + * dependent classes and objects. + * + * ---------------------------------------------------------------------- + */ static void ReleaseClassContents( @@ -1034,21 +1050,6 @@ ReleaseClassContents( } /* - * Squelch our instances. - */ - - if (clsPtr->instances.num) { - Object *oPtr; - - FOREACH(oPtr, clsPtr->instances) { - TclOODecrRefCount(oPtr); - } - ckfree(clsPtr->instances.list); - clsPtr->instances.list = NULL; - clsPtr->instances.num = 0; - } - - /* * Squelch our metadata. */ @@ -1064,11 +1065,24 @@ ReleaseClassContents( clsPtr->metadataPtr = NULL; } - FOREACH(tmpClsPtr, clsPtr->mixins) { - TclOORemoveFromMixinSubs(clsPtr, tmpClsPtr); + if (clsPtr->mixins.num) { + FOREACH(tmpClsPtr, clsPtr->mixins) { + TclOORemoveFromMixinSubs(clsPtr, tmpClsPtr); + TclOODecrRefCount(tmpClsPtr->thisPtr); + } + ckfree(clsPtr->mixins.list); + clsPtr->mixins.list = NULL; + clsPtr->mixins.num = 0; } - FOREACH(tmpClsPtr, clsPtr->superclasses) { - TclOORemoveFromSubclasses(clsPtr, tmpClsPtr); + + if (clsPtr->superclasses.num > 0) { + FOREACH(tmpClsPtr, clsPtr->superclasses) { + TclOORemoveFromSubclasses(clsPtr, tmpClsPtr); + TclOODecrRefCount(tmpClsPtr->thisPtr); + } + ckfree(clsPtr->superclasses.list); + clsPtr->superclasses.num = 0; + clsPtr->superclasses.list = NULL; } FOREACH_HASH_VALUE(mPtr, &clsPtr->classMethods) { @@ -1204,10 +1218,11 @@ ObjectNamespaceDeleted( TclOORemoveFromInstances(oPtr, oPtr->selfCls); - FOREACH(mixinPtr, oPtr->mixins) { - i -= TclOORemoveFromInstances(oPtr, mixinPtr); - } - if (i) { + if (oPtr->mixins.num > 0) { + FOREACH(mixinPtr, oPtr->mixins) { + TclOORemoveFromInstances(oPtr, mixinPtr); + TclOODecrRefCount(mixinPtr->thisPtr); + } ckfree(oPtr->mixins.list); } @@ -1276,7 +1291,9 @@ ObjectNamespaceDeleted( * Delete the object structure itself. */ + TclNsDecrRefCount((Namespace *)oPtr->namespacePtr); oPtr->namespacePtr = NULL; + TclOODecrRefCount(oPtr->selfCls->thisPtr); oPtr->selfCls = NULL; TclOODecrRefCount(oPtr); return; @@ -1299,14 +1316,8 @@ TclOODecrRefCount( Object *oPtr) { if (oPtr->refCount-- <= 1) { - Class *clsPtr = oPtr->classPtr; if (oPtr->classPtr != NULL) { - ckfree(clsPtr->superclasses.list); - ckfree(clsPtr->subclasses.list); - ckfree(clsPtr->instances.list); - ckfree(clsPtr->mixinSubs.list); - ckfree(clsPtr->mixins.list); ckfree(oPtr->classPtr); } ckfree(oPtr); @@ -1335,10 +1346,6 @@ TclOORemoveFromInstances( int i, res = 0; Object *instPtr; - if (Deleted(clsPtr->thisPtr)) { - return res; - } - FOREACH(instPtr, clsPtr->instances) { if (oPtr == instPtr) { RemoveItem(Object, clsPtr->instances, i); @@ -1401,10 +1408,6 @@ TclOORemoveFromSubclasses( int i, res = 0; Class *subclsPtr; - if (Deleted(superPtr->thisPtr)) { - return res; - } - FOREACH(subclsPtr, superPtr->subclasses) { if (subPtr == subclsPtr) { RemoveItem(Class, superPtr->subclasses, i); @@ -1469,10 +1472,6 @@ TclOORemoveFromMixinSubs( int i, res = 0; Class *subclsPtr; - if (Deleted(superPtr->thisPtr)) { - return res; - } - FOREACH(subclsPtr, superPtr->mixinSubs) { if (subPtr == subclsPtr) { RemoveItem(Class, superPtr->mixinSubs, i); @@ -1780,6 +1779,7 @@ TclNewObjectInstanceCommon( oPtr = AllocObject(interp, simpleName, nsPtr, nsNameStr); oPtr->selfCls = classPtr; + AddRef(classPtr->thisPtr); TclOOAddToInstances(oPtr, classPtr); /* @@ -1925,16 +1925,22 @@ Tcl_CopyObjectInstance( * Copy the object's mixin references to the new object. */ - FOREACH(mixinPtr, o2Ptr->mixins) { - if (mixinPtr && mixinPtr != o2Ptr->selfCls) { - TclOORemoveFromInstances(o2Ptr, mixinPtr); + if (o2Ptr->mixins.num != 0) { + FOREACH(mixinPtr, o2Ptr->mixins) { + if (mixinPtr && mixinPtr != o2Ptr->selfCls) { + TclOORemoveFromInstances(o2Ptr, mixinPtr); + } + TclOODecrRefCount(mixinPtr->thisPtr); } + ckfree(o2Ptr->mixins.list); } DUPLICATE(o2Ptr->mixins, oPtr->mixins, Class *); FOREACH(mixinPtr, o2Ptr->mixins) { if (mixinPtr && mixinPtr != o2Ptr->selfCls) { TclOOAddToInstances(o2Ptr, mixinPtr); } + /* For the reference just created in DUPLICATE */ + AddRef(mixinPtr->thisPtr); } /* @@ -2012,6 +2018,7 @@ Tcl_CopyObjectInstance( FOREACH(superPtr, cls2Ptr->superclasses) { TclOORemoveFromSubclasses(cls2Ptr, superPtr); + TclOODecrRefCount(superPtr->thisPtr); } if (cls2Ptr->superclasses.num) { cls2Ptr->superclasses.list = ckrealloc(cls2Ptr->superclasses.list, @@ -2025,6 +2032,11 @@ Tcl_CopyObjectInstance( cls2Ptr->superclasses.num = clsPtr->superclasses.num; FOREACH(superPtr, cls2Ptr->superclasses) { TclOOAddToSubclasses(cls2Ptr, superPtr); + + /* For the new item in cls2Ptr->superclasses that memcpy just + * created + */ + AddRef(superPtr->thisPtr); } /* @@ -2050,15 +2062,18 @@ Tcl_CopyObjectInstance( * references to the duplicate). */ - FOREACH(mixinPtr, cls2Ptr->mixins) { - TclOORemoveFromMixinSubs(cls2Ptr, mixinPtr); - } if (cls2Ptr->mixins.num != 0) { + FOREACH(mixinPtr, cls2Ptr->mixins) { + TclOORemoveFromMixinSubs(cls2Ptr, mixinPtr); + TclOODecrRefCount(mixinPtr->thisPtr); + } ckfree(clsPtr->mixins.list); } DUPLICATE(cls2Ptr->mixins, clsPtr->mixins, Class *); FOREACH(mixinPtr, cls2Ptr->mixins) { TclOOAddToMixinSubs(cls2Ptr, mixinPtr); + /* For the copy just created in DUPLICATE */ + AddRef(mixinPtr->thisPtr); } /* diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index 7c2a641..b443be8 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -332,6 +332,7 @@ TclOOObjectSetMixins( if (oPtr->mixins.num != 0) { FOREACH(mixinPtr, oPtr->mixins) { TclOORemoveFromInstances(oPtr, mixinPtr); + TclOODecrRefCount(mixinPtr->thisPtr); } ckfree(oPtr->mixins.list); oPtr->mixins.num = 0; @@ -343,6 +344,7 @@ TclOOObjectSetMixins( if (mixinPtr && mixinPtr != oPtr->selfCls) { TclOORemoveFromInstances(oPtr, mixinPtr); } + TclOODecrRefCount(mixinPtr->thisPtr); } oPtr->mixins.list = ckrealloc(oPtr->mixins.list, sizeof(Class *) * numMixins); @@ -355,13 +357,8 @@ TclOOObjectSetMixins( FOREACH(mixinPtr, oPtr->mixins) { if (mixinPtr != oPtr->selfCls) { TclOOAddToInstances(oPtr, mixinPtr); - - /* - * Corresponding TclOODecrRefCount() is in the caller of this - * function. - */ - - TclOODecrRefCount(mixinPtr->thisPtr); + /* For the new copy created by memcpy */ + AddRef(mixinPtr->thisPtr); } } } @@ -392,6 +389,7 @@ TclOOClassSetMixins( if (classPtr->mixins.num != 0) { FOREACH(mixinPtr, classPtr->mixins) { TclOORemoveFromMixinSubs(classPtr, mixinPtr); + TclOODecrRefCount(mixinPtr->thisPtr); } ckfree(classPtr->mixins.list); classPtr->mixins.num = 0; @@ -400,6 +398,7 @@ TclOOClassSetMixins( if (classPtr->mixins.num != 0) { FOREACH(mixinPtr, classPtr->mixins) { TclOORemoveFromMixinSubs(classPtr, mixinPtr); + TclOODecrRefCount(mixinPtr->thisPtr); } classPtr->mixins.list = ckrealloc(classPtr->mixins.list, sizeof(Class *) * numMixins); @@ -410,13 +409,8 @@ TclOOClassSetMixins( memcpy(classPtr->mixins.list, mixins, sizeof(Class *) * numMixins); FOREACH(mixinPtr, classPtr->mixins) { TclOOAddToMixinSubs(classPtr, mixinPtr); - - /* - * Corresponding TclOODecrRefCount() is in the caller of this - * function. - */ - - TclOODecrRefCount(mixinPtr->thisPtr); + /* For the new copy created by memcpy */ + AddRef(mixinPtr->thisPtr); } } BumpGlobalEpoch(interp, classPtr); @@ -1186,14 +1180,11 @@ TclOODefineClassObjCmd( if (oPtr->selfCls != clsPtr) { TclOORemoveFromInstances(oPtr, oPtr->selfCls); - - /* - * Reference count already incremented a few lines up. - */ - + TclOODecrRefCount(oPtr->selfCls->thisPtr); oPtr->selfCls = clsPtr; - + AddRef(oPtr->selfCls->thisPtr); TclOOAddToInstances(oPtr, oPtr->selfCls); + if (oPtr->classPtr != NULL) { BumpGlobalEpoch(interp, oPtr->classPtr); } else { @@ -1656,13 +1647,6 @@ TclOODefineMixinObjCmd( goto freeAndError; } mixins[i-1] = clsPtr; - - /* - * Corresponding TclOODecrRefCount() is in TclOOObjectSetMixins, - * TclOOClassSetMixinsk, or just below if this function fails. - */ - - AddRef(mixins[i-1]->thisPtr); } if (isInstanceMixin) { @@ -1675,9 +1659,6 @@ TclOODefineMixinObjCmd( return TCL_OK; freeAndError: - while (--i > 0) { - TclOODecrRefCount(mixins[i]->thisPtr); - } TclStackFree(interp, mixins); return TCL_ERROR; } @@ -2108,13 +2089,6 @@ ClassMixinSet( Tcl_SetErrorCode(interp, "TCL", "OO", "SELF_MIXIN", NULL); goto freeAndError; } - - /* - * Corresponding TclOODecrRefCount() is in TclOOClassSetMixins, or - * just below if this function fails. - */ - - AddRef(mixins[i]->thisPtr); } TclOOClassSetMixins(interp, oPtr->classPtr, mixinc, mixins); @@ -2122,9 +2096,6 @@ ClassMixinSet( return TCL_OK; freeAndError: - while (i-- > 0) { - TclOODecrRefCount(mixins[i]->thisPtr); - } TclStackFree(interp, mixins); return TCL_ERROR; } @@ -2234,11 +2205,6 @@ ClassSuperSet( superclasses[0] = oPtr->fPtr->objectCls; } superc = 1; - - /* - * Corresponding TclOODecrRefCount is near the end of this function. - */ - AddRef(superclasses[0]->thisPtr); } else { for (i=0 ; i<superc ; i++) { @@ -2288,6 +2254,7 @@ ClassSuperSet( if (oPtr->classPtr->superclasses.num != 0) { FOREACH(superPtr, oPtr->classPtr->superclasses) { TclOORemoveFromSubclasses(oPtr->classPtr, superPtr); + TclOODecrRefCount(superPtr->thisPtr); } ckfree(oPtr->classPtr->superclasses.list); } @@ -2295,12 +2262,6 @@ ClassSuperSet( oPtr->classPtr->superclasses.num = superc; FOREACH(superPtr, oPtr->classPtr->superclasses) { TclOOAddToSubclasses(oPtr->classPtr, superPtr); - - /* - * To account for the AddRef() earlier in this function. - */ - - TclOODecrRefCount(superPtr->thisPtr); } BumpGlobalEpoch(interp, oPtr->classPtr); @@ -2594,19 +2555,9 @@ ObjMixinSet( mixins[i] = GetClassInOuterContext(interp, mixinv[i], "may only mix in classes"); if (mixins[i] == NULL) { - while (i-- > 0) { - TclOODecrRefCount(mixins[i]->thisPtr); - } TclStackFree(interp, mixins); return TCL_ERROR; } - - /* - * Corresponding TclOODecrRefCount() is in TclOOObjectSetMixins() or - * just above if this function fails. - */ - - AddRef(mixins[i]->thisPtr); } TclOOObjectSetMixins(oPtr, mixinc, mixins); diff --git a/generic/tclPipe.c b/generic/tclPipe.c index b679ec4..f94fe5c 100644 --- a/generic/tclPipe.c +++ b/generic/tclPipe.c @@ -221,13 +221,13 @@ Tcl_ReapDetachedProcs(void) { register Detached *detPtr; Detached *nextPtr, *prevPtr; - int status; - Tcl_Pid pid; + int status, code; Tcl_MutexLock(&pipeMutex); for (detPtr = detList, prevPtr = NULL; detPtr != NULL; ) { - pid = Tcl_WaitPid(detPtr->pid, &status, WNOHANG); - if ((pid == 0) || ((pid == (Tcl_Pid) -1) && (errno != ECHILD))) { + status = TclProcessWait(detPtr->pid, WNOHANG, &code, NULL, NULL); + if (status == TCL_PROCESS_UNCHANGED || (status == TCL_PROCESS_ERROR + && code != ECHILD)) { prevPtr = detPtr; detPtr = detPtr->nextPtr; continue; @@ -277,38 +277,21 @@ TclCleanupChildren( { int result = TCL_OK; int i, abnormalExit, anyErrorInfo; - Tcl_Pid pid; - int waitStatus; - const char *msg; - unsigned long resolvedPid; + TclProcessWaitStatus waitStatus; + int code; + Tcl_Obj *msg, *error; abnormalExit = 0; for (i = 0; i < numPids; i++) { - /* - * We need to get the resolved pid before we wait on it as the windows - * implementation of Tcl_WaitPid deletes the information such that any - * following calls to TclpGetPid fail. - */ - - resolvedPid = TclpGetPid(pidPtr[i]); - pid = Tcl_WaitPid(pidPtr[i], &waitStatus, 0); - if (pid == (Tcl_Pid) -1) { + waitStatus = TclProcessWait(pidPtr[i], 0, &code, &msg, &error); + if (waitStatus == TCL_PROCESS_ERROR) { result = TCL_ERROR; if (interp != NULL) { - msg = Tcl_PosixError(interp); - if (errno == ECHILD) { - /* - * This changeup in message suggested by Mark Diekhans to - * remind people that ECHILD errors can occur on some - * systems if SIGCHLD isn't in its default state. - */ - - msg = - "child process lost (is SIGCHLD ignored or trapped?)"; - } - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "error waiting for process to exit: %s", msg)); + Tcl_SetObjErrorCode(interp, error); + Tcl_SetObjResult(interp, msg); } + Tcl_DecrRefCount(error); + Tcl_DecrRefCount(msg); continue; } @@ -319,39 +302,19 @@ TclCleanupChildren( * removed). */ - if (!WIFEXITED(waitStatus) || (WEXITSTATUS(waitStatus) != 0)) { - char msg1[TCL_INTEGER_SPACE], msg2[TCL_INTEGER_SPACE]; - + if (waitStatus != TCL_PROCESS_EXITED || code != 0) { result = TCL_ERROR; - sprintf(msg1, "%lu", resolvedPid); - if (WIFEXITED(waitStatus)) { + if (waitStatus == TCL_PROCESS_EXITED) { if (interp != NULL) { - sprintf(msg2, "%u", WEXITSTATUS(waitStatus)); - Tcl_SetErrorCode(interp, "CHILDSTATUS", msg1, msg2, NULL); + Tcl_SetObjErrorCode(interp, error); } abnormalExit = 1; } else if (interp != NULL) { - const char *p; - - if (WIFSIGNALED(waitStatus)) { - p = Tcl_SignalMsg(WTERMSIG(waitStatus)); - Tcl_SetErrorCode(interp, "CHILDKILLED", msg1, - Tcl_SignalId(WTERMSIG(waitStatus)), p, NULL); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "child killed: %s\n", p)); - } else if (WIFSTOPPED(waitStatus)) { - p = Tcl_SignalMsg(WSTOPSIG(waitStatus)); - Tcl_SetErrorCode(interp, "CHILDSUSP", msg1, - Tcl_SignalId(WSTOPSIG(waitStatus)), p, NULL); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "child suspended: %s\n", p)); - } else { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "child wait status didn't make sense\n", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", - "ODDWAITRESULT", msg1, NULL); - } + Tcl_SetObjErrorCode(interp, error); + Tcl_SetObjResult(interp, msg); } + Tcl_DecrRefCount(error); + Tcl_DecrRefCount(msg); } } @@ -936,6 +899,7 @@ TclCreatePipeline( pidPtr[numPids] = pid; numPids++; + TclProcessCreated(pid); /* * Close off our copies of file descriptors that were set up for this diff --git a/generic/tclProcess.c b/generic/tclProcess.c new file mode 100644 index 0000000..7187ee4 --- /dev/null +++ b/generic/tclProcess.c @@ -0,0 +1,952 @@ +/* + * tclProcess.c -- + * + * This file implements the "tcl::process" ensemble for subprocess + * management as defined by TIP #462. + * + * Copyright (c) 2017 Frederic Bonnet. + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +#include "tclInt.h" + +/* + * Autopurge flag. Process-global because of the way Tcl manages child + * processes (see tclPipe.c). + */ + +static int autopurge = 1; /* Autopurge flag. */ + +/* + * Hash tables that keeps track of all child process statuses. Keys are the + * child process ids and resolved pids, values are (ProcessInfo *). + */ + +typedef struct ProcessInfo { + Tcl_Pid pid; /* Process id. */ + int resolvedPid; /* Resolved process id. */ + int purge; /* Purge eventualy. */ + TclProcessWaitStatus status;/* Process status. */ + int code; /* Error code, exit status or signal + number. */ + Tcl_Obj *msg; /* Error message. */ + Tcl_Obj *error; /* Error code. */ +} ProcessInfo; +static Tcl_HashTable infoTablePerPid; +static Tcl_HashTable infoTablePerResolvedPid; +static int infoTablesInitialized = 0; /* 0 means not yet initialized. */ +TCL_DECLARE_MUTEX(infoTablesMutex) + + /* + * Prototypes for functions defined later in this file: + */ + +static void InitProcessInfo(ProcessInfo *info, Tcl_Pid pid, + int resolvedPid); +static void FreeProcessInfo(ProcessInfo *info); +static int RefreshProcessInfo(ProcessInfo *info, int options); +static TclProcessWaitStatus WaitProcessStatus(Tcl_Pid pid, int resolvedPid, + int options, int *codePtr, Tcl_Obj **msgPtr, + Tcl_Obj **errorObjPtr); +static Tcl_Obj * BuildProcessStatusObj(ProcessInfo *info); +static int ProcessListObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static int ProcessStatusObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static int ProcessPurgeObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static int ProcessAutopurgeObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); + +/* + *---------------------------------------------------------------------- + * + * InitProcessInfo -- + * + * Initializes the ProcessInfo structure. + * + * Results: + * None. + * + * Side effects: + * Memory written. + * + *---------------------------------------------------------------------- + */ + +void +InitProcessInfo( + ProcessInfo *info, /* Structure to initialize. */ + Tcl_Pid pid, /* Process id. */ + int resolvedPid) /* Resolved process id. */ +{ + info->pid = pid; + info->resolvedPid = resolvedPid; + info->purge = 0; + info->status = TCL_PROCESS_UNCHANGED; + info->code = 0; + info->msg = NULL; + info->error = NULL; +} + +/* + *---------------------------------------------------------------------- + * + * FreeProcessInfo -- + * + * Free the ProcessInfo structure. + * + * Results: + * None. + * + * Side effects: + * Memory deallocated, Tcl_Obj refcount decreased. + * + *---------------------------------------------------------------------- + */ + +void +FreeProcessInfo( + ProcessInfo *info) /* Structure to free. */ +{ + /* + * Free stored Tcl_Objs. + */ + + if (info->msg) { + Tcl_DecrRefCount(info->msg); + } + if (info->error) { + Tcl_DecrRefCount(info->error); + } + + /* + * Free allocated structure. + */ + + ckfree(info); +} + +/* + *---------------------------------------------------------------------- + * + * RefreshProcessInfo -- + * + * Refresh process info. + * + * Results: + * Nonzero if state changed, else zero. + * + * Side effects: + * May call WaitProcessStatus, which can block if WNOHANG option is set. + * + *---------------------------------------------------------------------- + */ + +int +RefreshProcessInfo( + ProcessInfo *info, /* Structure to refresh. */ + int options /* Options passed to WaitProcessStatus. */ +) +{ + if (info->status == TCL_PROCESS_UNCHANGED) { + /* + * Refresh & store status. + */ + + info->status = WaitProcessStatus(info->pid, info->resolvedPid, + options, &info->code, &info->msg, &info->error); + if (info->msg) Tcl_IncrRefCount(info->msg); + if (info->error) Tcl_IncrRefCount(info->error); + return (info->status != TCL_PROCESS_UNCHANGED); + } else { + /* + * No change. + */ + + return 0; + } +} + +/* + *---------------------------------------------------------------------- + * + * WaitProcessStatus -- + * + * Wait for process status to change. + * + * Results: + * TclProcessWaitStatus enum value. + * + * Side effects: + * May call WaitProcessStatus, which can block if WNOHANG option is set. + * + *---------------------------------------------------------------------- + */ + +TclProcessWaitStatus +WaitProcessStatus( + Tcl_Pid pid, /* Process id. */ + int resolvedPid, /* Resolved process id. */ + int options, /* Options passed to Tcl_WaitPid. */ + int *codePtr, /* If non-NULL, will receive either: + * - 0 for normal exit. + * - errno in case of error. + * - non-zero exit code for abormal exit. + * - signal number if killed or suspended. + * - Tcl_WaitPid status in all other cases. + */ + Tcl_Obj **msgObjPtr, /* If non-NULL, will receive error message. */ + Tcl_Obj **errorObjPtr) /* If non-NULL, will receive error code. */ +{ + int waitStatus; + Tcl_Obj *errorStrings[5]; + const char *msg; + + pid = Tcl_WaitPid(pid, &waitStatus, options); + if (pid == 0) { + /* + * No change. + */ + + return TCL_PROCESS_UNCHANGED; + } + + /* + * Get process status. + */ + + if (pid == (Tcl_Pid) -1) { + /* + * POSIX errName msg + */ + + msg = Tcl_ErrnoMsg(errno); + if (errno == ECHILD) { + /* + * This changeup in message suggested by Mark Diekhans to + * remind people that ECHILD errors can occur on some + * systems if SIGCHLD isn't in its default state. + */ + + msg = "child process lost (is SIGCHLD ignored or trapped?)"; + } + if (codePtr) *codePtr = errno; + if (msgObjPtr) *msgObjPtr = Tcl_ObjPrintf( + "error waiting for process to exit: %s", msg); + if (errorObjPtr) { + errorStrings[0] = Tcl_NewStringObj("POSIX", -1); + errorStrings[1] = Tcl_NewStringObj(Tcl_ErrnoId(), -1); + errorStrings[2] = Tcl_NewStringObj(msg, -1); + *errorObjPtr = Tcl_NewListObj(3, errorStrings); + } + return TCL_PROCESS_ERROR; + } else if (WIFEXITED(waitStatus)) { + if (codePtr) *codePtr = WEXITSTATUS(waitStatus); + if (!WEXITSTATUS(waitStatus)) { + /* + * Normal exit. + */ + + if (msgObjPtr) *msgObjPtr = NULL; + if (errorObjPtr) *errorObjPtr = NULL; + } else { + /* + * CHILDSTATUS pid code + * + * Child exited with a non-zero exit status. + */ + + if (msgObjPtr) *msgObjPtr = Tcl_NewStringObj( + "child process exited abnormally", -1); + if (errorObjPtr) { + errorStrings[0] = Tcl_NewStringObj("CHILDSTATUS", -1); + errorStrings[1] = Tcl_NewIntObj(resolvedPid); + errorStrings[2] = Tcl_NewIntObj(WEXITSTATUS(waitStatus)); + *errorObjPtr = Tcl_NewListObj(3, errorStrings); + } + } + return TCL_PROCESS_EXITED; + } else if (WIFSIGNALED(waitStatus)) { + /* + * CHILDKILLED pid sigName msg + * + * Child killed because of a signal. + */ + + msg = Tcl_SignalMsg(WTERMSIG(waitStatus)); + if (codePtr) *codePtr = WTERMSIG(waitStatus); + if (msgObjPtr) *msgObjPtr = Tcl_ObjPrintf( + "child killed: %s", msg); + if (errorObjPtr) { + errorStrings[0] = Tcl_NewStringObj("CHILDKILLED", -1); + errorStrings[1] = Tcl_NewIntObj(resolvedPid); + errorStrings[2] = Tcl_NewStringObj(Tcl_SignalId(WTERMSIG(waitStatus)), -1); + errorStrings[3] = Tcl_NewStringObj(msg, -1); + *errorObjPtr = Tcl_NewListObj(4, errorStrings); + } + return TCL_PROCESS_SIGNALED; + } else if (WIFSTOPPED(waitStatus)) { + /* + * CHILDSUSP pid sigName msg + * + * Child suspended because of a signal. + */ + + msg = Tcl_SignalMsg(WSTOPSIG(waitStatus)); + if (codePtr) *codePtr = WSTOPSIG(waitStatus); + if (msgObjPtr) *msgObjPtr = Tcl_ObjPrintf( + "child suspended: %s", msg); + if (errorObjPtr) { + errorStrings[0] = Tcl_NewStringObj("CHILDSUSP", -1); + errorStrings[1] = Tcl_NewIntObj(resolvedPid); + errorStrings[2] = Tcl_NewStringObj(Tcl_SignalId(WSTOPSIG(waitStatus)), -1); + errorStrings[3] = Tcl_NewStringObj(msg, -1); + *errorObjPtr = Tcl_NewListObj(4, errorStrings); + } + return TCL_PROCESS_STOPPED; + } else { + /* + * TCL OPERATION EXEC ODDWAITRESULT + * + * Child wait status didn't make sense. + */ + + if (codePtr) *codePtr = waitStatus; + if (msgObjPtr) *msgObjPtr = Tcl_NewStringObj( + "child wait status didn't make sense\n", -1); + if (errorObjPtr) { + errorStrings[0] = Tcl_NewStringObj("TCL", -1); + errorStrings[1] = Tcl_NewStringObj("OPERATION", -1); + errorStrings[2] = Tcl_NewStringObj("EXEC", -1); + errorStrings[3] = Tcl_NewStringObj("ODDWAITRESULT", -1); + errorStrings[4] = Tcl_NewIntObj(resolvedPid); + *errorObjPtr = Tcl_NewListObj(5, errorStrings); + } + return TCL_PROCESS_UNKNOWN_STATUS; + } +} + + +/* + *---------------------------------------------------------------------- + * + * BuildProcessStatusObj -- + * + * Build a list object with process status. The first element is always + * a standard Tcl return value, which can be either TCL_OK or TCL_ERROR. + * In the latter case, the second element is the error message and the + * third element is a Tcl error code (see tclvars). + * + * Results: + * A list object. + * + * Side effects: + * Tcl_Objs are created. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +BuildProcessStatusObj( + ProcessInfo *info) +{ + Tcl_Obj *resultObjs[3]; + + if (info->status == TCL_PROCESS_UNCHANGED) { + /* + * Process still running, return empty obj. + */ + + return Tcl_NewObj(); + } + if (info->status == TCL_PROCESS_EXITED && info->code == 0) { + /* + * Normal exit, return TCL_OK. + */ + + return Tcl_NewIntObj(TCL_OK); + } + + /* + * Abnormal exit, return {TCL_ERROR msg error} + */ + + resultObjs[0] = Tcl_NewIntObj(TCL_ERROR); + resultObjs[1] = info->msg; + resultObjs[2] = info->error; + return Tcl_NewListObj(3, resultObjs); +} + +/*---------------------------------------------------------------------- + * + * ProcessListObjCmd -- + * + * This function implements the 'tcl::process list' Tcl command. + * Refer to the user documentation for details on what it does. + * + * Results: + * Returns a standard Tcl result. + * + * Side effects: + * Access to the internal structures is protected by infoTablesMutex. + * + *---------------------------------------------------------------------- + */ + +static int +ProcessListObjCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tcl_Obj *list; + Tcl_HashEntry *entry; + Tcl_HashSearch search; + ProcessInfo *info; + + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return TCL_ERROR; + } + + /* + * Return the list of all chid process ids. + */ + + list = Tcl_NewListObj(0, NULL); + Tcl_MutexLock(&infoTablesMutex); + for (entry = Tcl_FirstHashEntry(&infoTablePerResolvedPid, &search); + entry != NULL; entry = Tcl_NextHashEntry(&search)) { + info = (ProcessInfo *) Tcl_GetHashValue(entry); + Tcl_ListObjAppendElement(interp, list, + Tcl_NewIntObj(info->resolvedPid)); + } + Tcl_MutexUnlock(&infoTablesMutex); + Tcl_SetObjResult(interp, list); + return TCL_OK; +} + +/*---------------------------------------------------------------------- + * + * ProcessStatusObjCmd -- + * + * This function implements the 'tcl::process status' Tcl command. + * Refer to the user documentation for details on what it does. + * + * Results: + * Returns a standard Tcl result. + * + * Side effects: + * Access to the internal structures is protected by infoTablesMutex. + * Calls RefreshProcessInfo, which can block if -wait switch is given. + * + *---------------------------------------------------------------------- + */ + +static int +ProcessStatusObjCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tcl_Obj *dict; + int index, options = WNOHANG; + Tcl_HashEntry *entry; + Tcl_HashSearch search; + ProcessInfo *info; + int numPids; + Tcl_Obj **pidObjs; + int result; + int i; + int pid; + Tcl_Obj *const *savedobjv = objv; + static const char *const switches[] = { + "-wait", "--", NULL + }; + enum switches { + STATUS_WAIT, STATUS_LAST + }; + + while (objc > 1) { + if (TclGetString(objv[1])[0] != '-') { + break; + } + if (Tcl_GetIndexFromObj(interp, objv[1], switches, "switches", 0, + &index) != TCL_OK) { + return TCL_ERROR; + } + ++objv; --objc; + if (STATUS_WAIT == (enum switches) index) { + options = 0; + } else { + break; + } + } + + if (objc != 1 && objc != 2) { + Tcl_WrongNumArgs(interp, 1, savedobjv, "?switches? ?pids?"); + return TCL_ERROR; + } + + if (objc == 1) { + /* + * Return a dict with all child process statuses. + */ + + dict = Tcl_NewDictObj(); + Tcl_MutexLock(&infoTablesMutex); + for (entry = Tcl_FirstHashEntry(&infoTablePerResolvedPid, &search); + entry != NULL; entry = Tcl_NextHashEntry(&search)) { + info = (ProcessInfo *) Tcl_GetHashValue(entry); + RefreshProcessInfo(info, options); + + if (info->purge && autopurge) { + /* + * Purge entry. + */ + + Tcl_DeleteHashEntry(entry); + entry = Tcl_FindHashEntry(&infoTablePerPid, info->pid); + Tcl_DeleteHashEntry(entry); + FreeProcessInfo(info); + } else { + /* + * Add to result. + */ + + Tcl_DictObjPut(interp, dict, Tcl_NewIntObj(info->resolvedPid), + BuildProcessStatusObj(info)); + } + } + Tcl_MutexUnlock(&infoTablesMutex); + } else { + /* + * Only return statuses of provided processes. + */ + + result = Tcl_ListObjGetElements(interp, objv[1], &numPids, &pidObjs); + if (result != TCL_OK) { + return result; + } + dict = Tcl_NewDictObj(); + Tcl_MutexLock(&infoTablesMutex); + for (i = 0; i < numPids; i++) { + result = Tcl_GetIntFromObj(interp, pidObjs[i], (int *) &pid); + if (result != TCL_OK) { + Tcl_MutexUnlock(&infoTablesMutex); + Tcl_DecrRefCount(dict); + return result; + } + + entry = Tcl_FindHashEntry(&infoTablePerResolvedPid, INT2PTR(pid)); + if (!entry) { + /* + * Skip unknown process. + */ + + continue; + } + + info = (ProcessInfo *) Tcl_GetHashValue(entry); + RefreshProcessInfo(info, options); + + if (info->purge && autopurge) { + /* + * Purge entry. + */ + + Tcl_DeleteHashEntry(entry); + entry = Tcl_FindHashEntry(&infoTablePerPid, info->pid); + Tcl_DeleteHashEntry(entry); + FreeProcessInfo(info); + } else { + /* + * Add to result. + */ + + Tcl_DictObjPut(interp, dict, Tcl_NewIntObj(info->resolvedPid), + BuildProcessStatusObj(info)); + } + } + Tcl_MutexUnlock(&infoTablesMutex); + } + Tcl_SetObjResult(interp, dict); + return TCL_OK; +} + +/*---------------------------------------------------------------------- + * + * ProcessPurgeObjCmd -- + * + * This function implements the 'tcl::process purge' Tcl command. + * Refer to the user documentation for details on what it does. + * + * Results: + * Returns a standard Tcl result. + * + * Side effects: + * Frees all ProcessInfo structures with their purge flag set. + * + *---------------------------------------------------------------------- + */ + +static int +ProcessPurgeObjCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tcl_HashEntry *entry; + Tcl_HashSearch search; + ProcessInfo *info; + int numPids; + Tcl_Obj **pidObjs; + int result; + int i; + int pid; + + if (objc != 1 && objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "?pids?"); + return TCL_ERROR; + } + + /* + * First reap detached procs so that their purge flag is up-to-date. + */ + + Tcl_ReapDetachedProcs(); + + if (objc == 1) { + /* + * Purge all terminated processes. + */ + + Tcl_MutexLock(&infoTablesMutex); + for (entry = Tcl_FirstHashEntry(&infoTablePerResolvedPid, &search); + entry != NULL; entry = Tcl_NextHashEntry(&search)) { + info = (ProcessInfo *) Tcl_GetHashValue(entry); + if (info->purge) { + Tcl_DeleteHashEntry(entry); + entry = Tcl_FindHashEntry(&infoTablePerPid, info->pid); + Tcl_DeleteHashEntry(entry); + FreeProcessInfo(info); + } + } + Tcl_MutexUnlock(&infoTablesMutex); + } else { + /* + * Purge only provided processes. + */ + + result = Tcl_ListObjGetElements(interp, objv[1], &numPids, &pidObjs); + if (result != TCL_OK) { + return result; + } + Tcl_MutexLock(&infoTablesMutex); + for (i = 0; i < numPids; i++) { + result = Tcl_GetIntFromObj(interp, pidObjs[i], (int *) &pid); + if (result != TCL_OK) { + Tcl_MutexUnlock(&infoTablesMutex); + return result; + } + + entry = Tcl_FindHashEntry(&infoTablePerResolvedPid, INT2PTR(pid)); + if (!entry) { + /* + * Skip unknown process. + */ + + continue; + } + + info = (ProcessInfo *) Tcl_GetHashValue(entry); + if (info->purge) { + Tcl_DeleteHashEntry(entry); + entry = Tcl_FindHashEntry(&infoTablePerPid, info->pid); + Tcl_DeleteHashEntry(entry); + FreeProcessInfo(info); + } + } + Tcl_MutexUnlock(&infoTablesMutex); + } + + return TCL_OK; +} + +/*---------------------------------------------------------------------- + * + * ProcessAutopurgeObjCmd -- + * + * This function implements the 'tcl::process autopurge' Tcl command. + * Refer to the user documentation for details on what it does. + * + * Results: + * Returns a standard Tcl result. + * + * Side effects: + * Alters detached process handling by Tcl_ReapDetachedProcs(). + * + *---------------------------------------------------------------------- + */ + +static int +ProcessAutopurgeObjCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + if (objc != 1 && objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "?flag?"); + return TCL_ERROR; + } + + if (objc == 2) { + /* + * Set given value. + */ + + int flag; + int result = Tcl_GetBooleanFromObj(interp, objv[1], &flag); + if (result != TCL_OK) { + return result; + } + + autopurge = !!flag; + } + + /* + * Return current value. + */ + + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(autopurge)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclInitProcessCmd -- + * + * This procedure creates the "tcl::process" Tcl command. See the user + * documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +Tcl_Command +TclInitProcessCmd( + Tcl_Interp *interp) /* Current interpreter. */ +{ + static const EnsembleImplMap processImplMap[] = { + {"list", ProcessListObjCmd, TclCompileBasic0ArgCmd, NULL, NULL, 1}, + {"status", ProcessStatusObjCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 1}, + {"purge", ProcessPurgeObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1}, + {"autopurge", ProcessAutopurgeObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1}, + {NULL, NULL, NULL, NULL, NULL, 0} + }; + Tcl_Command processCmd; + + if (infoTablesInitialized == 0) { + Tcl_MutexLock(&infoTablesMutex); + if (infoTablesInitialized == 0) { + Tcl_InitHashTable(&infoTablePerPid, TCL_ONE_WORD_KEYS); + Tcl_InitHashTable(&infoTablePerResolvedPid, TCL_ONE_WORD_KEYS); + infoTablesInitialized = 1; + } + Tcl_MutexUnlock(&infoTablesMutex); + } + + processCmd = TclMakeEnsemble(interp, "::tcl::process", processImplMap); + Tcl_Export(interp, Tcl_FindNamespace(interp, "::tcl", NULL, 0), + "process", 0); + return processCmd; +} + +/* + *---------------------------------------------------------------------- + * + * TclProcessCreated -- + * + * Called when a child process has been created by Tcl. + * + * Results: + * None. + * + * Side effects: + * Internal structures are updated with a new ProcessInfo. + * + *---------------------------------------------------------------------- + */ + +void +TclProcessCreated( + Tcl_Pid pid) /* Process id. */ +{ + int resolvedPid; + Tcl_HashEntry *entry, *entry2; + int isNew; + ProcessInfo *info; + + /* + * Get resolved pid first. + */ + + resolvedPid = TclpGetPid(pid); + + Tcl_MutexLock(&infoTablesMutex); + + /* + * Create entry in pid table. + */ + + entry = Tcl_CreateHashEntry(&infoTablePerPid, pid, &isNew); + if (!isNew) { + /* + * Pid was reused, free old info and reuse structure. + */ + + info = (ProcessInfo *) Tcl_GetHashValue(entry); + entry2 = Tcl_FindHashEntry(&infoTablePerResolvedPid, + INT2PTR(resolvedPid)); + if (entry2) Tcl_DeleteHashEntry(entry2); + FreeProcessInfo(info); + } + + /* + * Allocate and initialize info structure. + */ + + info = (ProcessInfo *) ckalloc(sizeof(ProcessInfo)); + InitProcessInfo(info, pid, resolvedPid); + + /* + * Add entry to tables. + */ + + Tcl_SetHashValue(entry, info); + entry = Tcl_CreateHashEntry(&infoTablePerResolvedPid, INT2PTR(resolvedPid), + &isNew); + Tcl_SetHashValue(entry, info); + + Tcl_MutexUnlock(&infoTablesMutex); +} + +/* + *---------------------------------------------------------------------- + * + * TclProcessWait -- + * + * Wait for process status to change. + * + * Results: + * TclProcessWaitStatus enum value. + * + * Side effects: + * Completed process info structures are purged immediately (autopurge on) + * or eventually (autopurge off). + * + *---------------------------------------------------------------------- + */ + +TclProcessWaitStatus +TclProcessWait( + Tcl_Pid pid, /* Process id. */ + int options, /* Options passed to WaitProcessStatus. */ + int *codePtr, /* If non-NULL, will receive either: + * - 0 for normal exit. + * - errno in case of error. + * - non-zero exit code for abormal exit. + * - signal number if killed or suspended. + * - Tcl_WaitPid status in all other cases. + */ + Tcl_Obj **msgObjPtr, /* If non-NULL, will receive error message. */ + Tcl_Obj **errorObjPtr) /* If non-NULL, will receive error code. */ +{ + Tcl_HashEntry *entry; + ProcessInfo *info; + TclProcessWaitStatus result; + + /* + * First search for pid in table. + */ + + entry = Tcl_FindHashEntry(&infoTablePerPid, pid); + if (!entry) { + /* + * Unknown process, just call WaitProcessStatus and return. + */ + + result = WaitProcessStatus(pid, TclpGetPid(pid), options, codePtr, + msgObjPtr, errorObjPtr); + if (msgObjPtr && *msgObjPtr) Tcl_IncrRefCount(*msgObjPtr); + if (errorObjPtr && *errorObjPtr) Tcl_IncrRefCount(*errorObjPtr); + return result; + } + + info = (ProcessInfo *) Tcl_GetHashValue(entry); + if (info->purge) { + /* + * Process has completed but TclProcessWait has already been called, + * so report no change. + */ + + return TCL_PROCESS_UNCHANGED; + } + + RefreshProcessInfo(info, options); + if (info->status == TCL_PROCESS_UNCHANGED) { + /* + * No change, stop there. + */ + + return TCL_PROCESS_UNCHANGED; + } + + /* + * Set return values. + */ + + result = info->status; + if (codePtr) *codePtr = info->code; + if (msgObjPtr) *msgObjPtr = info->msg; + if (errorObjPtr) *errorObjPtr = info->error; + if (msgObjPtr && *msgObjPtr) Tcl_IncrRefCount(*msgObjPtr); + if (errorObjPtr && *errorObjPtr) Tcl_IncrRefCount(*errorObjPtr); + + if (autopurge) { + /* + * Purge now. + */ + + Tcl_DeleteHashEntry(entry); + entry = Tcl_FindHashEntry(&infoTablePerResolvedPid, + INT2PTR(info->resolvedPid)); + Tcl_DeleteHashEntry(entry); + FreeProcessInfo(info); + } else { + /* + * Eventually purge. Subsequent calls will return + * TCL_PROCESS_UNCHANGED. + */ + + info->purge = 1; + } + return result; +} diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 0933c15..78569de 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -38,6 +38,7 @@ #include "tommath.h" #include "tclStringRep.h" +#include "assert.h" /* * Prototypes for functions defined later in this file: */ @@ -3531,6 +3532,150 @@ TclStringReverse( /* *--------------------------------------------------------------------------- * + * TclStringReplace -- + * + * Implements the inner engine of the [string replace] command. + * + * The result is a concatenation of a prefix from objPtr, characters + * 0 through first-1, the insertPtr string value, and a suffix from + * objPtr, characters from first + count to the end. The effect is + * as if the inner substring of characters first through first+count-1 + * are removed and replaced with insertPtr. + * If insertPtr is NULL, it is treated as an empty string. + * When passed the flag TCL_STRING_IN_PLACE, this routine will try + * to do the work within objPtr, so long as no sharing forbids it. + * Without that request, or as needed, a new Tcl value will be allocated + * to be the result. + * + * Results: + * A Tcl value that is the result of the substring replacement. + * May return NULL in case of an error. When NULL is returned and + * interp is non-NULL, error information is left in interp + * + *--------------------------------------------------------------------------- + */ + +Tcl_Obj * +TclStringReplace( + Tcl_Interp *interp, /* For error reporting, may be NULL */ + Tcl_Obj *objPtr, /* String to act upon */ + int first, /* First index to replace */ + int count, /* How many chars to replace */ + Tcl_Obj *insertPtr, /* Replacement string, may be NULL */ + int flags) /* TCL_STRING_IN_PLACE => attempt in-place */ +{ + int inPlace = flags & TCL_STRING_IN_PLACE; + Tcl_Obj *result; + + /* Caller is expected to pass sensible arguments */ + assert ( count >= 0 ) ; + assert ( first >= 0 ) ; + + /* Replace nothing with nothing */ + if ((insertPtr == NULL) && (count == 0)) { + if (inPlace) { + return objPtr; + } else { + return Tcl_DuplicateObj(objPtr); + } + } + + /* + * The caller very likely had to call Tcl_GetCharLength() or similar + * to be able to process index values. This means it is like that + * objPtr is either a proper "bytearray" or a "string" or else it has + * a known and short string rep. + */ + + if (TclIsPureByteArray(objPtr)) { + int numBytes; + unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, &numBytes); + + if (insertPtr == NULL) { + /* Replace something with nothing. */ + + assert ( first <= numBytes ) ; + assert ( count <= numBytes ) ; + assert ( first + count <= numBytes ) ; + + result = Tcl_NewByteArrayObj(NULL, numBytes - count);/* PANIC? */ + TclAppendBytesToByteArray(result, bytes, first); + TclAppendBytesToByteArray(result, bytes + first + count, + numBytes - count - first); + return result; + } + + /* Replace everything */ + if ((first == 0) && (count == numBytes)) { + return insertPtr; + } + + if (TclIsPureByteArray(insertPtr)) { + int newBytes; + unsigned char *iBytes + = Tcl_GetByteArrayFromObj(insertPtr, &newBytes); + + if (count == newBytes && inPlace && !Tcl_IsShared(objPtr)) { + /* + * Removal count and replacement count are equal. + * Other conditions permit. Do in-place splice. + */ + + memcpy(bytes + first, iBytes, count); + Tcl_InvalidateStringRep(objPtr); + return objPtr; + } + + if (newBytes > INT_MAX - (numBytes - count)) { + if (interp) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "max size for a Tcl value (%d bytes) exceeded", + INT_MAX)); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + } + return NULL; + } + result = Tcl_NewByteArrayObj(NULL, numBytes - count + newBytes); + /* PANIC? */ + TclAppendBytesToByteArray(result, bytes, first); + TclAppendBytesToByteArray(result, iBytes, newBytes); + TclAppendBytesToByteArray(result, bytes + first + count, + numBytes - count - first); + return result; + } + + /* Flow through to try other approaches below */ + } + + /* + * TODO: Figure out how not to generate a Tcl_UniChar array rep + * when it can be determined objPtr->bytes points to a string of + * all single-byte characters so we can index it directly. + */ + + /* The traditional implementation... */ + { + int numChars; + Tcl_UniChar *ustring = Tcl_GetUnicodeFromObj(objPtr, &numChars); + + /* TODO: Is there an in-place option worth pursuing here? */ + + result = Tcl_NewUnicodeObj(ustring, first); + if (insertPtr) { + Tcl_AppendObjToObj(result, insertPtr); + } + if (first + count < numChars) { + Tcl_AppendUnicodeToObj(result, ustring + first + count, + numChars - first - count); + } + + return result; + } +} + +/* + *--------------------------------------------------------------------------- + * * FillUnicodeRep -- * * Populate the Unicode internal rep with the Unicode form of its string diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 3833e30..9136c21 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -1645,11 +1645,46 @@ Tcl_Backslash( /* *---------------------------------------------------------------------- * - * TclTrimRight -- + * UtfWellFormedEnd -- + * Checks the end of utf string is malformed, if yes - wraps bytes + * to the given buffer (as well-formed NTS string). The buffer + * argument should be initialized by the caller and ready to use. + * + * Results: + * The bytes with well-formed end of the string. * - * Takes two counted strings in the Tcl encoding which must both be null - * terminated. Conceptually trims from the right side of the first string - * all characters found in the second string. + * Side effects: + * Buffer (DString) may be allocated, so must be released. + * + *---------------------------------------------------------------------- + */ + +static inline const char* +UtfWellFormedEnd( + Tcl_DString *buffer, /* Buffer used to hold well-formed string. */ + const char *bytes, /* Pointer to the beginning of the string. */ + int length) /* Length of the string. */ +{ + const char *l = bytes + length; + const char *p = Tcl_UtfPrev(l, bytes); + + if (Tcl_UtfCharComplete(p, l - p)) { + return bytes; + } + /* + * Malformed utf-8 end, be sure we've NTS to safe compare of end-character, + * avoid segfault by access violation out of range. + */ + Tcl_DStringAppend(buffer, bytes, length); + return Tcl_DStringValue(buffer); +} +/* + *---------------------------------------------------------------------- + * + * TclTrimRight -- + * Takes two counted strings in the Tcl encoding. Conceptually + * finds the sub string (offset) to trim from the right side of the + * first string all characters found in the second string. * * Results: * The number of bytes to be removed from the end of the string. @@ -1660,8 +1695,8 @@ Tcl_Backslash( *---------------------------------------------------------------------- */ -int -TclTrimRight( +static inline int +TrimRight( const char *bytes, /* String to be trimmed... */ int numBytes, /* ...and its length in bytes */ const char *trim, /* String of trim characters... */ @@ -1671,18 +1706,6 @@ TclTrimRight( int pInc; Tcl_UniChar ch1 = 0, ch2 = 0; - if ((bytes[numBytes] != '\0') || (trim[numTrim] != '\0')) { - Tcl_Panic("TclTrimRight works only on null-terminated strings"); - } - - /* - * Empty strings -> nothing to do. - */ - - if ((numBytes == 0) || (numTrim == 0)) { - return 0; - } - /* * Outer loop: iterate over string to be trimmed. */ @@ -1721,15 +1744,46 @@ TclTrimRight( return numBytes - (p - bytes); } + +int +TclTrimRight( + const char *bytes, /* String to be trimmed... */ + int numBytes, /* ...and its length in bytes */ + const char *trim, /* String of trim characters... */ + int numTrim) /* ...and its length in bytes */ +{ + int res; + Tcl_DString bytesBuf, trimBuf; + + /* Empty strings -> nothing to do */ + if ((numBytes == 0) || (numTrim == 0)) { + return 0; + } + + Tcl_DStringInit(&bytesBuf); + Tcl_DStringInit(&trimBuf); + bytes = UtfWellFormedEnd(&bytesBuf, bytes, numBytes); + trim = UtfWellFormedEnd(&trimBuf, trim, numTrim); + + res = TrimRight(bytes, numBytes, trim, numTrim); + if (res > numBytes) { + res = numBytes; + } + + Tcl_DStringFree(&bytesBuf); + Tcl_DStringFree(&trimBuf); + + return res; +} /* *---------------------------------------------------------------------- * * TclTrimLeft -- * - * Takes two counted strings in the Tcl encoding which must both be null - * terminated. Conceptually trims from the left side of the first string - * all characters found in the second string. + * Takes two counted strings in the Tcl encoding. Conceptually + * finds the sub string (offset) to trim from the left side of the + * first string all characters found in the second string. * * Results: * The number of bytes to be removed from the start of the string. @@ -1740,8 +1794,8 @@ TclTrimRight( *---------------------------------------------------------------------- */ -int -TclTrimLeft( +static inline int +TrimLeft( const char *bytes, /* String to be trimmed... */ int numBytes, /* ...and its length in bytes */ const char *trim, /* String of trim characters... */ @@ -1750,18 +1804,6 @@ TclTrimLeft( const char *p = bytes; Tcl_UniChar ch1 = 0, ch2 = 0; - if ((bytes[numBytes] != '\0') || (trim[numTrim] != '\0')) { - Tcl_Panic("TclTrimLeft works only on null-terminated strings"); - } - - /* - * Empty strings -> nothing to do. - */ - - if ((numBytes == 0) || (numTrim == 0)) { - return 0; - } - /* * Outer loop: iterate over string to be trimmed. */ @@ -1796,10 +1838,99 @@ TclTrimLeft( p += pInc; numBytes -= pInc; - } while (numBytes); + } while (numBytes > 0); return p - bytes; } + +int +TclTrimLeft( + const char *bytes, /* String to be trimmed... */ + int numBytes, /* ...and its length in bytes */ + const char *trim, /* String of trim characters... */ + int numTrim) /* ...and its length in bytes */ +{ + int res; + Tcl_DString bytesBuf, trimBuf; + + /* Empty strings -> nothing to do */ + if ((numBytes == 0) || (numTrim == 0)) { + return 0; + } + + Tcl_DStringInit(&bytesBuf); + Tcl_DStringInit(&trimBuf); + bytes = UtfWellFormedEnd(&bytesBuf, bytes, numBytes); + trim = UtfWellFormedEnd(&trimBuf, trim, numTrim); + + res = TrimLeft(bytes, numBytes, trim, numTrim); + if (res > numBytes) { + res = numBytes; + } + + Tcl_DStringFree(&bytesBuf); + Tcl_DStringFree(&trimBuf); + + return res; +} + +/* + *---------------------------------------------------------------------- + * + * TclTrim -- + * Finds the sub string (offset) to trim from both sides of the + * first string all characters found in the second string. + * + * Results: + * The number of bytes to be removed from the start of the string + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclTrim( + const char *bytes, /* String to be trimmed... */ + int numBytes, /* ...and its length in bytes */ + const char *trim, /* String of trim characters... */ + int numTrim, /* ...and its length in bytes */ + int *trimRight) /* Offset from the end of the string. */ +{ + int trimLeft; + Tcl_DString bytesBuf, trimBuf; + + *trimRight = 0; + /* Empty strings -> nothing to do */ + if ((numBytes == 0) || (numTrim == 0)) { + return 0; + } + + Tcl_DStringInit(&bytesBuf); + Tcl_DStringInit(&trimBuf); + bytes = UtfWellFormedEnd(&bytesBuf, bytes, numBytes); + trim = UtfWellFormedEnd(&trimBuf, trim, numTrim); + + trimLeft = TrimLeft(bytes, numBytes, trim, numTrim); + if (trimLeft > numBytes) { + trimLeft = numBytes; + } + numBytes -= trimLeft; + /* have to trim yet (first char was already verified within TrimLeft) */ + if (numBytes > 1) { + bytes += trimLeft; + *trimRight = TrimRight(bytes, numBytes, trim, numTrim); + if (*trimRight > numBytes) { + *trimRight = numBytes; + } + } + + Tcl_DStringFree(&bytesBuf); + Tcl_DStringFree(&trimBuf); + + return trimLeft; +} /* *---------------------------------------------------------------------- @@ -1867,30 +1998,20 @@ Tcl_Concat( result = ckalloc((unsigned) (bytesNeeded + argc)); for (p = result, i = 0; i < argc; i++) { - int trim, elemLength; + int triml, trimr, elemLength; const char *element; element = argv[i]; elemLength = strlen(argv[i]); - /* - * Trim away the leading whitespace. - */ - - trim = TclTrimLeft(element, elemLength, CONCAT_TRIM_SET, - CONCAT_WS_SIZE); - element += trim; - elemLength -= trim; - - /* - * Trim away the trailing whitespace. Do not permit trimming to expose - * a final backslash character. - */ + /* Trim away the leading/trailing whitespace. */ + triml = TclTrim(element, elemLength, CONCAT_TRIM_SET, + CONCAT_WS_SIZE, &trimr); + element += triml; + elemLength -= triml + trimr; - trim = TclTrimRight(element, elemLength, CONCAT_TRIM_SET, - CONCAT_WS_SIZE); - trim -= trim && (element[elemLength - trim - 1] == '\\'); - elemLength -= trim; + /* Do not permit trimming to expose a final backslash character. */ + elemLength += trimr && (element[elemLength - 1] == '\\'); /* * If we're left with empty element after trimming, do nothing. @@ -2010,28 +2131,18 @@ Tcl_ConcatObj( Tcl_SetObjLength(resPtr, 0); for (i = 0; i < objc; i++) { - int trim; + int triml, trimr; element = TclGetStringFromObj(objv[i], &elemLength); - /* - * Trim away the leading whitespace. - */ - - trim = TclTrimLeft(element, elemLength, CONCAT_TRIM_SET, - CONCAT_WS_SIZE); - element += trim; - elemLength -= trim; - - /* - * Trim away the trailing whitespace. Do not permit trimming to expose - * a final backslash character. - */ + /* Trim away the leading/trailing whitespace. */ + triml = TclTrim(element, elemLength, CONCAT_TRIM_SET, + CONCAT_WS_SIZE, &trimr); + element += triml; + elemLength -= triml + trimr; - trim = TclTrimRight(element, elemLength, CONCAT_TRIM_SET, - CONCAT_WS_SIZE); - trim -= trim && (element[elemLength - trim - 1] == '\\'); - elemLength -= trim; + /* Do not permit trimming to expose a final backslash character. */ + elemLength += trimr && (element[elemLength - 1] == '\\'); /* * If we're left with empty element after trimming, do nothing. diff --git a/library/msgcat/msgcat.tcl b/library/msgcat/msgcat.tcl index 646bc17..598330d 100644 --- a/library/msgcat/msgcat.tcl +++ b/library/msgcat/msgcat.tcl @@ -4,22 +4,24 @@ # message catalog facility for Tcl programs. It should be # loaded with the command "package require msgcat". # -# Copyright (c) 2010-2015 by Harald Oehlmann. +# Copyright (c) 2010-2018 by Harald Oehlmann. # Copyright (c) 1998-2000 by Ajuba Solutions. # Copyright (c) 1998 by Mark Harrison. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require Tcl 8.5- +# We use oo::define::self, which is new in Tcl 8.7 +package require Tcl 8.7- # When the version number changes, be sure to update the pkgIndex.tcl file, # and the installation directory in the Makefiles. -package provide msgcat 1.6.1 +package provide msgcat 1.7.0 namespace eval msgcat { - namespace export mc mcexists mcload mclocale mcmax mcmset mcpreferences mcset\ + namespace export mc mcn mcexists mcload mclocale mcmax\ + mcmset mcpreferences mcset\ mcunknown mcflset mcflmset mcloadedlocales mcforgetpackage\ - mcpackageconfig mcpackagelocale + mcpackagenamespaceget mcpackageconfig mcpackagelocale mcutil # Records the list of locales to search variable Loclist {} @@ -41,7 +43,13 @@ namespace eval msgcat { # namespace should be themselves dict values and the value is # the translated string. variable Msgs [dict create] +} +# create ensemble namespace for mcutil command +namespace eval msgcat::mcutil { + namespace export getsystemlocale getpreferences + namespace ensemble create -prefix 0 + # Map of language codes used in Windows registry to those of ISO-639 if {[info sharedlibextension] eq ".dll"} { variable WinRegToISO639 [dict create {*}{ @@ -192,10 +200,30 @@ namespace eval msgcat { # Returns the translated string. Propagates errors thrown by the # format command. -proc msgcat::mc {src args} { - # this may be replaced by: - # return [mcget -namespace [uplevel 1 [list ::namespace current]] --\ - # $src {*}$args] +proc msgcat::mc {args} { + tailcall mcn [PackageNamespaceGet] {*}$args +} + +# msgcat::mcn -- +# +# Find the translation for the given string based on the current +# locale setting. Check the passed namespace first, then look in each +# parent namespace until the source is found. If additional args are +# specified, use the format command to work them into the traslated +# string. +# If no catalog item is found, mcunknown is called in the caller frame +# and its result is returned. +# +# Arguments: +# ns Package namespace of the translation +# src The string to translate. +# args Args to pass to the format command +# +# Results: +# Returns the translated string. Propagates errors thrown by the +# format command. + +proc msgcat::mcn {ns src args} { # Check for the src in each namespace starting from the local and # ending in the global. @@ -203,7 +231,6 @@ proc msgcat::mc {src args} { variable Msgs variable Loclist - set ns [uplevel 1 [list ::namespace current]] set loclist [PackagePreferences $ns] set nscur $ns @@ -219,7 +246,7 @@ proc msgcat::mc {src args} { # call package local or default unknown command set args [linsert $args 0 [lindex $loclist 0] $src] switch -exact -- [Invoke unknowncmd $args $ns result 1] { - 0 { return [uplevel 1 [linsert $args 0 [namespace origin mcunknown]]] } + 0 { tailcall mcunknown {*}$args } 1 { return [DefaultUnknown {*}$args] } default { return $result } } @@ -245,23 +272,31 @@ proc msgcat::mcexists {args} { variable Loclist variable PackageConfig - set ns [uplevel 1 [list ::namespace current]] - set loclist [PackagePreferences $ns] - while {[llength $args] != 1} { set args [lassign $args option] switch -glob -- $option { - -exactnamespace { set exactnamespace 1 } - -exactlocale { set loclist [lrange $loclist 0 0] } + -exactnamespace - -exactlocale { set $option 1 } + -namespace { + if {[llength $args] < 2} { + return -code error\ + "Argument missing for switch \"-namespace\"" + } + set args [lassign $args ns] + } -* { return -code error "unknown option \"$option\"" } default { return -code error "wrong # args: should be\ \"[lindex [info level 0] 0] ?-exactnamespace?\ - ?-exactlocale? src\"" + ?-exactlocale? ?-namespace ns? src\"" } } } set src [lindex $args 0] + + if {![info exists ns]} { set ns [PackageNamespaceGet] } + + set loclist [PackagePreferences $ns] + if {[info exists -exactlocale]} { set loclist [lrange $loclist 0 0] } while {$ns ne ""} { foreach loc $loclist { @@ -269,7 +304,7 @@ proc msgcat::mcexists {args} { return 1 } } - if {[info exists exactnamespace]} {return 0} + if {[info exists -exactnamespace]} {return 0} set ns [namespace parent $ns] } return 0 @@ -303,32 +338,27 @@ proc msgcat::mclocale {args} { return -code error "invalid newLocale value \"$newLocale\":\ could be path to unsafe code." } - if {[lindex $Loclist 0] ne $newLocale} { - set Loclist [GetPreferences $newLocale] - - # locale not loaded jet - LoadAll $Loclist - # Invoke callback - Invoke changecmd $Loclist - } + mcpreferences {*}[mcutil getpreferences $newLocale] } return [lindex $Loclist 0] } -# msgcat::GetPreferences -- +# msgcat::mcutil::getpreferences -- # # Get list of locales from a locale. # The first element is always the lowercase locale. # Other elements have one component separated by "_" less. # Multiple "_" are seen as one separator: de__ch_spec de__ch de {} # +# This method is part of the ensemble mcutil +# # Arguments: # Locale. # # Results: # Locale list -proc msgcat::GetPreferences {locale} { +proc msgcat::mcutil::getpreferences {locale} { set locale [string tolower $locale] set loclist [list $locale] while {-1 !=[set pos [string last "_" $locale]]} { @@ -349,16 +379,51 @@ proc msgcat::GetPreferences {locale} { # most preferred to least preferred. # # Arguments: -# None. +# New location list # # Results: # Returns an ordered list of the locales preferred by the user. -proc msgcat::mcpreferences {} { +proc msgcat::mcpreferences {args} { variable Loclist + + if {[llength $args] > 0} { + # args is the new loclist + if {![ListEqualString $args $Loclist]} { + set Loclist $args + + # locale not loaded jet + LoadAll $Loclist + # Invoke callback + Invoke changecmd $Loclist + } + } return $Loclist } +# msgcat::ListStringEqual -- +# +# Compare two strings for equal string contents +# +# Arguments: +# list1 first list +# list2 second list +# +# Results: +# 1 if lists of strings are identical, 0 otherwise + +proc msgcat::ListEqualString {list1 list2} { + if {[llength $list1] != [llength $list2]} { + return 0 + } + foreach item1 $list1 item2 $list2 { + if {$item1 ne $item2} { + return 0 + } + } + return 1 +} + # msgcat::mcloadedlocales -- # # Get or change the list of currently loaded default locales @@ -442,7 +507,7 @@ proc msgcat::mcloadedlocales {subcommand} { # Results: # Empty string, if not stated differently for the subcommand -proc msgcat::mcpackagelocale {subcommand {locale ""}} { +proc msgcat::mcpackagelocale {subcommand args} { # todo: implement using an ensemble variable Loclist variable LoadedLocales @@ -450,27 +515,39 @@ proc msgcat::mcpackagelocale {subcommand {locale ""}} { variable PackageConfig # Check option # check if required item is exactly provided - if {[llength [info level 0]] == 2} { - # locale not given - unset locale - } else { - # locale given - if {$subcommand in - {"get" "isset" "unset" "preferences" "loaded" "clear"} } { - return -code error "wrong # args: should be\ - \"[lrange [info level 0] 0 1]\"" - } - set locale [string tolower $locale] + if { [llength $args] > 0 + && $subcommand in {"get" "isset" "unset" "loaded" "clear"} } { + return -code error "wrong # args: should be\ + \"[lrange [info level 0] 0 1]\"" } - set ns [uplevel 1 {::namespace current}] + set ns [PackageNamespaceGet] switch -exact -- $subcommand { get { return [lindex [PackagePreferences $ns] 0] } - preferences { return [PackagePreferences $ns] } loaded { return [PackageLocales $ns] } - present { return [expr {$locale in [PackageLocales $ns]} ]} + present { + if {[llength $args] != 1} { + return -code error "wrong # args: should be\ + \"[lrange [info level 0] 0 1] locale\"" + } + return [expr {[string tolower [lindex $args 0]] + in [PackageLocales $ns]} ] + } isset { return [dict exists $PackageConfig loclist $ns] } - set { # set a package locale or add a package locale + set - preferences { + # set a package locale or add a package locale + set fSet [expr {$subcommand eq "set"}] + + # Check parameter + if {$fSet && 1 < [llength $args] } { + return -code error "wrong # args: should be\ + \"[lrange [info level 0] 0 1] ?locale?\"" + } + + # > Return preferences if no parameter + if {!$fSet && 0 == [llength $args] } { + return [PackagePreferences $ns] + } # Copy the default locale if no package locale set so far if {![dict exists $PackageConfig loclist $ns]} { @@ -478,25 +555,43 @@ proc msgcat::mcpackagelocale {subcommand {locale ""}} { dict set PackageConfig loadedlocales $ns $LoadedLocales } - # Check if changed - set loclist [dict get $PackageConfig loclist $ns] - if {! [info exists locale] || $locale eq [lindex $loclist 0] } { - return [lindex $loclist 0] + # No argument for set: return current package locale + # The difference to no argument and subcommand "preferences" is, + # that "preferences" does not set the package locale property. + # This case is processed above, so no check for fSet here + if { 0 == [llength $args] } { + return [lindex [dict get $PackageConfig loclist $ns] 0] + } + + # Get new loclist + if {$fSet} { + set loclist [mcutil getpreferences [lindex $args 0]] + } else { + set loclist $args + } + + # Check if not changed to return imediately + if { [ListEqualString $loclist\ + [dict get $PackageConfig loclist $ns]] } { + if {$fSet} { + return [lindex $loclist 0] + } + return $loclist } # Change loclist - set loclist [GetPreferences $locale] - set locale [lindex $loclist 0] dict set PackageConfig loclist $ns $loclist # load eventual missing locales set loadedLocales [dict get $PackageConfig loadedlocales $ns] - if {$locale in $loadedLocales} { return $locale } set loadLocales [ListComplement $loadedLocales $loclist] dict set PackageConfig loadedlocales $ns\ [concat $loadedLocales $loadLocales] Load $ns $loadLocales - return $locale + if {$fSet} { + return [lindex $loclist 0] + } + return $loclist } clear { # Remove all locales not contained in Loclist if {![dict exists $PackageConfig loclist $ns]} { @@ -551,7 +646,7 @@ proc msgcat::mcforgetpackage {} { # todo: this may be implemented using an ensemble variable PackageConfig variable Msgs - set ns [uplevel 1 {::namespace current}] + set ns [PackageNamespaceGet] # Remove MC items dict unset Msgs $ns # Remove config items @@ -561,6 +656,15 @@ proc msgcat::mcforgetpackage {} { return } +# msgcat::mcgetmynamespace -- +# +# Return the package namespace of the caller +# This consideres to be called from a class or object. + +proc msgcat::mcpackagenamespaceget {} { + return [PackageNamespaceGet] +} + # msgcat::mcpackageconfig -- # # Get or modify the per caller namespace (e.g. packages) config options. @@ -616,7 +720,7 @@ proc msgcat::mcforgetpackage {} { proc msgcat::mcpackageconfig {subcommand option {value ""}} { variable PackageConfig # get namespace - set ns [uplevel 1 {::namespace current}] + set ns [PackageNamespaceGet] if {$option ni {"mcfolder" "loadcmd" "changecmd" "unknowncmd"}} { return -code error "bad option \"$option\": must be mcfolder, loadcmd,\ @@ -756,8 +860,7 @@ proc msgcat::ListComplement {list1 list2 {inlistname ""}} { # Returns the number of message catalogs that were loaded. proc msgcat::mcload {langdir} { - return [uplevel 1 [list\ - [namespace origin mcpackageconfig] set mcfolder $langdir]] + tailcall mcpackageconfig set mcfolder $langdir } # msgcat::LoadAll -- @@ -923,7 +1026,7 @@ proc msgcat::mcset {locale src {dest ""}} { set dest $src } - set ns [uplevel 1 [list ::namespace current]] + set ns [PackageNamespaceGet] set locale [string tolower $locale] @@ -951,7 +1054,7 @@ proc msgcat::mcflset {src {dest ""}} { return -code error "must only be used inside a message catalog loaded\ with ::msgcat::mcload" } - return [uplevel 1 [list [namespace origin mcset] $FileLocale $src $dest]] + tailcall mcset $FileLocale $src $dest } # msgcat::mcmset -- @@ -975,7 +1078,7 @@ proc msgcat::mcmset {locale pairs} { } set locale [string tolower $locale] - set ns [uplevel 1 [list ::namespace current]] + set ns [PackageNamespaceGet] foreach {src dest} $pairs { dict set Msgs $ns $locale $src $dest @@ -1002,7 +1105,7 @@ proc msgcat::mcflmset {pairs} { return -code error "must only be used inside a message catalog loaded\ with ::msgcat::mcload" } - return [uplevel 1 [list [namespace origin mcmset] $FileLocale $pairs]] + tailcal mcmset $FileLocale $pairs } # msgcat::mcunknown -- @@ -1024,7 +1127,7 @@ proc msgcat::mcflmset {pairs} { # Returns the translated value. proc msgcat::mcunknown {args} { - return [uplevel 1 [list [namespace origin DefaultUnknown] {*}$args]] + tailcall DefaultUnknown {*}$args } # msgcat::DefaultUnknown -- @@ -1067,8 +1170,9 @@ proc msgcat::DefaultUnknown {locale src args} { proc msgcat::mcmax {args} { set max 0 + set ns [PackageNamespaceGet] foreach string $args { - set translated [uplevel 1 [list [namespace origin mc] $string]] + set translated [uplevel 1 [list [namespace origin mcn] $ns $string]] set len [string length $translated] if {$len>$max} { set max $len @@ -1079,7 +1183,7 @@ proc msgcat::mcmax {args} { # Convert the locale values stored in environment variables to a form # suitable for passing to [mclocale] -proc msgcat::ConvertLocale {value} { +proc msgcat::mcutil::ConvertLocale {value} { # Assume $value is of form: $language[_$territory][.$codeset][@modifier] # Convert to form: $language[_$territory][_$modifier] # @@ -1106,8 +1210,40 @@ proc msgcat::ConvertLocale {value} { return $ret } +# helper function to find package namespace of stack-frame -2 +# There are 4 possibilities: +# - called from a proc +# - called within a class definition script +# - called from an class defined oo object +# - called from a classless oo object +proc ::msgcat::PackageNamespaceGet {} { + uplevel 2 { + # Check self namespace to determine environment + switch -exact -- [namespace which self] { + {::oo::define::self} { + # We are within a class definition + return [namespace qualifiers [self]] + } + {::oo::Helpers::self} { + # We are within an object + set Class [info object class [self]] + # Check for classless defined object + if {$Class eq {::oo::object}} { + return [namespace qualifiers [self]] + } + # Class defined object + return [namespace qualifiers $Class] + } + default { + # Not in object environment + return [namespace current] + } + } + } +} + # Initialize the default locale -proc msgcat::Init {} { +proc msgcat::mcutil::getsystemlocale {} { global env # @@ -1115,10 +1251,8 @@ proc msgcat::Init {} { # foreach varName {LC_ALL LC_MESSAGES LANG} { if {[info exists env($varName)] && ("" ne $env($varName))} { - if {![catch { - mclocale [ConvertLocale $env($varName)] - }]} { - return + if {![catch { ConvertLocale $env($varName) } locale]} { + return $locale } } } @@ -1126,10 +1260,8 @@ proc msgcat::Init {} { # On Darwin, fallback to current CFLocale identifier if available. # if {[info exists ::tcl::mac::locale] && $::tcl::mac::locale ne ""} { - if {![catch { - mclocale [ConvertLocale $::tcl::mac::locale] - }]} { - return + if {![catch { ConvertLocale $::tcl::mac::locale } locale]} { + return $locale } } # @@ -1138,8 +1270,7 @@ proc msgcat::Init {} { # if {([info sharedlibextension] ne ".dll") || [catch {package require registry}]} { - mclocale C - return + return C } # # On Windows or Cygwin, try to set locale depending on registry @@ -1170,8 +1301,8 @@ proc msgcat::Init {} { if {[dict exists $modifierDict $script]} { append locale @ [dict get $modifierDict $script] } - if {![catch {mclocale [ConvertLocale $locale]}]} { - return + if {![catch {ConvertLocale $locale} locale]} { + return $locale } } } @@ -1180,8 +1311,7 @@ proc msgcat::Init {} { if {[catch { set locale [registry get $key "locale"] }]} { - mclocale C - return + return C } # # Keep trying to match against smaller and smaller suffixes @@ -1196,15 +1326,15 @@ proc msgcat::Init {} { set locale [string tolower $locale] while {[string length $locale]} { if {![catch { - mclocale [ConvertLocale [dict get $WinRegToISO639 $locale]] - }]} { - return + ConvertLocale [dict get $WinRegToISO639 $locale] + } localeOut]} { + return $localeOut } set locale [string range $locale 1 end] } # # No translation known. Fall back on "C" locale # - mclocale C + return C } -msgcat::Init +msgcat::mclocale [msgcat::mcutil getsystemlocale] diff --git a/library/msgcat/pkgIndex.tcl b/library/msgcat/pkgIndex.tcl index 72c5dc0..3309a30 100644 --- a/library/msgcat/pkgIndex.tcl +++ b/library/msgcat/pkgIndex.tcl @@ -1,2 +1,2 @@ -if {![package vsatisfies [package provide Tcl] 8.5-]} {return} -package ifneeded msgcat 1.6.1 [list source [file join $dir msgcat.tcl]] +if {![package vsatisfies [package provide Tcl] 8.7-]} {return} +package ifneeded msgcat 1.7.0 [list source [file join $dir msgcat.tcl]] diff --git a/tests/coroutine.test b/tests/coroutine.test index 07feb53..8217a92 100644 --- a/tests/coroutine.test +++ b/tests/coroutine.test @@ -739,6 +739,8 @@ test coroutine-7.12 {coro floor above street level #3008307} -body { } boom ; # does not crash: the coro floor is a good insulator list +} -cleanup { + rename boom {}; rename cc {}; rename c {} } -result {} test coroutine-8.0.0 {coro inject executed} -body { diff --git a/tests/foreach.test b/tests/foreach.test index 6fd5476..84af4bd 100644 --- a/tests/foreach.test +++ b/tests/foreach.test @@ -212,14 +212,16 @@ test foreach-6.4 {break tests} { set msg } {wrong # args: should be "break"} # Check for bug #406709 -test foreach-6.5 {break tests} { +test foreach-6.5 {break tests} -body { proc a {} { set a 1 foreach b b {list [concat a; break]; incr a} incr a } a -} {2} +} -cleanup { + rename a {} +} -result {2} # Test for incorrect "double evaluation" semantics test foreach-7.1 {delayed substitution of body} { diff --git a/tests/ioCmd.test b/tests/ioCmd.test index b4ba04a..cab4e97 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -2057,6 +2057,8 @@ test iocmd-32.0 {origin interpreter of moved channel gone} -match glob -body { lappend res [catch {interp eval $idb [list close $chan]} msg] $msg set res +} -cleanup { + interp delete $idb } -constraints {testchannel} \ -result {1 {Owner lost} 1 {Owner lost} 1 {Owner lost} 1 {Owner lost} 1 {Owner lost}} @@ -2099,6 +2101,8 @@ test iocmd-32.1 {origin interpreter of moved channel destroyed during access} -m set res }] set res +} -cleanup { + interp delete $idb } -constraints {testchannel} -result {Owner lost} test iocmd-32.2 {delete interp of reflected chan} { diff --git a/tests/ioTrans.test b/tests/ioTrans.test index 63a609f..75752f7 100644 --- a/tests/ioTrans.test +++ b/tests/ioTrans.test @@ -1200,6 +1200,7 @@ test iortrans-11.0 {origin interpreter of moved transform gone} -setup { # without invoking the transform handler. } -cleanup { tempdone + interp delete $idb } -result {1 {Owner lost} 0 0 1 {Owner lost} 1 {Owner lost} 1 {Owner lost}} test iortrans-11.1 {origin interpreter of moved transform destroyed during access} -setup { set ida [interp create]; #puts <<$ida>> @@ -1240,6 +1241,7 @@ test iortrans-11.1 {origin interpreter of moved transform destroyed during acces }] } -cleanup { tempdone + interp delete $idb } -result {Owner lost} test iortrans-11.2 {delete interp of reflected transform} -setup { interp create slave diff --git a/tests/msgcat.test b/tests/msgcat.test index 1c3ce58..0d2f928 100644 --- a/tests/msgcat.test +++ b/tests/msgcat.test @@ -55,8 +55,13 @@ namespace eval ::msgcat::test { set result [string tolower [lindex $setVars 0]] if {[string length $result] == 0} { if {[info exists ::tcl::mac::locale]} { +if {[package vsatisfies [package provide msgcat] 1.7]} { + set result [string tolower \ + [msgcat::mcutil::ConvertLocale $::tcl::mac::locale]] +} else { set result [string tolower \ [msgcat::ConvertLocale $::tcl::mac::locale]] +} } else { if {([info sharedlibextension] eq ".dll") && ![catch {package require registry}]} { @@ -194,6 +199,28 @@ namespace eval ::msgcat::test { mclocale looks/ok/../../../../but/is/path/to/evil/code } -returnCodes error -match glob -result {invalid newLocale value *} + test msgcat-1.14 {mcpreferences, custom locale preferences} -setup { + variable locale [mclocale] + mclocale en + mcpreferences fr en {} + } -cleanup { + mclocale $locale + } -body { + mcpreferences + } -result {fr en {}} + + test msgcat-1.15 {mcpreferences, overwrite custom locale preferences}\ + -setup { + variable locale [mclocale] + mcpreferences fr en {} + mclocale en + } -cleanup { + mclocale $locale + } -body { + mcpreferences + } -result {en {}} + + # Tests msgcat-2.*: [mcset], [mcmset], namespace partitioning test msgcat-2.1 {mcset, global scope} { @@ -688,7 +715,7 @@ namespace eval ::msgcat::test { test msgcat-9.1 {mcexists no parameter} -body { mcexists } -returnCodes 1\ - -result {wrong # args: should be "mcexists ?-exactnamespace? ?-exactlocale? src"} + -result {wrong # args: should be "mcexists ?-exactnamespace? ?-exactlocale? ?-namespace ns? src"} test msgcat-9.2 {mcexists unknown option} -body { mcexists -unknown src @@ -724,12 +751,34 @@ namespace eval ::msgcat::test { mcset foo k1 v1 } -cleanup { mclocale $locale + namespace delete ::foo } -body { - namespace eval ::msgcat::test::sub { + namespace eval ::foo { list [::msgcat::mcexists k1]\ - [::msgcat::mcexists -exactnamespace k1] + [::msgcat::mcexists -namespace ::msgcat::test k1] } - } -result {1 0} + } -result {0 1} + + test msgcat-9.6 {mcexists -namespace ns parameter} -setup { + mcforgetpackage + variable locale [mclocale] + mclocale foo_bar + mcset foo k1 v1 + } -cleanup { + mclocale $locale + namespace delete ::foo + } -body { + namespace eval ::foo { + list [::msgcat::mcexists k1]\ + [::msgcat::mcexists -namespace ::msgcat::test k1] + } + } -result {0 1} + + test msgcat-9.7 {mcexists -namespace - ns argument missing} -body { + mcexists -namespace src + } -returnCodes 1\ + -result {Argument missing for switch "-namespace"} + # Tests msgcat-10.*: [mcloadedlocales] @@ -811,13 +860,18 @@ namespace eval ::msgcat::test { test msgcat-12.1 {mcpackagelocale no subcommand} -body { mcpackagelocale } -returnCodes 1\ - -result {wrong # args: should be "mcpackagelocale subcommand ?locale?"} + -result {wrong # args: should be "mcpackagelocale subcommand ?arg ...?"} test msgcat-12.2 {mclpackagelocale wrong subcommand} -body { mcpackagelocale junk } -returnCodes 1\ -result {unknown subcommand "junk": must be clear, get, isset, loaded, present, set, or unset} + test msgcat-12.2.1 {mclpackagelocale set multiple args} -body { + mcpackagelocale set a b + } -returnCodes 1\ + -result {wrong # args: should be "mcpackagelocale set ?locale?"} + test msgcat-12.3 {mcpackagelocale set} -setup { variable locale [mclocale] } -cleanup { @@ -922,6 +976,30 @@ namespace eval ::msgcat::test { list [mcpackagelocale present foo] [mcpackagelocale present bar] } -result {0 1} + test msgcat-12.11 {mcpackagelocale custom preferences} -setup { + variable locale [mclocale] + } -cleanup { + mclocale $locale + mcforgetpackage + } -body { + mclocale foo + set res [list [mcpackagelocale preferences]] + mcpackagelocale preferences bar {} + lappend res [mcpackagelocale preferences] + } -result {{foo {}} {bar {}}} + + test msgcat-12.12 {mcpackagelocale preferences -> no isset} -setup { + variable locale [mclocale] + } -cleanup { + mclocale $locale + mcforgetpackage + } -body { + mclocale foo + mcpackagelocale preferences + mcpackagelocale isset + } -result {0} + + # Tests msgcat-13.*: [mcpackageconfig subcmds] test msgcat-13.1 {mcpackageconfig no subcommand} -body { @@ -1073,8 +1151,212 @@ namespace eval ::msgcat::test { } -returnCodes 1\ -result {fail} + + # Tests msgcat-15.*: tcloo coverage + + # There are 4 use-cases, where 3 must be tested now: + # - namespace defined, in class definition, class defined oo, classless + + test msgcat-15.1 {mc in class setup} -setup { + # full namespace is ::msgcat::test:bar + namespace eval bar { + ::msgcat::mcset foo_BAR con2 con2bar + oo::class create ClassCur + } + variable locale [mclocale] + mclocale foo_BAR + } -cleanup { + mclocale $locale + namespace eval bar {::msgcat::mcforgetpackage} + namespace delete bar + } -body { + oo::define bar::ClassCur msgcat::mc con2 + } -result con2bar + + test msgcat-15.2 {mc in class} -setup { + # full namespace is ::msgcat::test:bar + namespace eval bar { + ::msgcat::mcset foo_BAR con2 con2bar + oo::class create ClassCur + oo::define ClassCur method method1 {} {::msgcat::mc con2} + } + # full namespace is ::msgcat::test:baz + namespace eval baz { + set ObjCur [::msgcat::test::bar::ClassCur new] + } + variable locale [mclocale] + mclocale foo_BAR + } -cleanup { + mclocale $locale + namespace eval bar {::msgcat::mcforgetpackage} + namespace delete bar baz + } -body { + $baz::ObjCur method1 + } -result con2bar + + test msgcat-15.3 {mc in classless object} -setup { + # full namespace is ::msgcat::test:bar + namespace eval bar { + ::msgcat::mcset foo_BAR con2 con2bar + oo::object create ObjCur + oo::objdefine ObjCur method method1 {} {::msgcat::mc con2} + } + variable locale [mclocale] + mclocale foo_BAR + } -cleanup { + mclocale $locale + namespace eval bar {::msgcat::mcforgetpackage} + namespace delete bar + } -body { + bar::ObjCur method1 + } -result con2bar + + test msgcat-15.4 {mc in classless object with explicite namespace eval}\ + -setup { + # full namespace is ::msgcat::test:bar + namespace eval bar { + ::msgcat::mcset foo_BAR con2 con2bar + oo::object create ObjCur + oo::objdefine ObjCur method method1 {} { + namespace eval ::msgcat::test::baz { + ::msgcat::mc con2 + } + } + } + namespace eval baz { + ::msgcat::mcset foo_BAR con2 con2baz + } + variable locale [mclocale] + mclocale foo_BAR + } -cleanup { + mclocale $locale + namespace eval bar {::msgcat::mcforgetpackage} + namespace eval baz {::msgcat::mcforgetpackage} + namespace delete bar baz + } -body { + bar::ObjCur method1 + } -result con2baz + + # Test msgcat-16.*: command mcpackagenamespaceget + + test msgcat-16.1 {mcpackagenamespaceget in namespace procedure} -body { + namespace eval baz {msgcat::mcpackagenamespaceget} + } -result ::msgcat::test::baz + + test msgcat-16.2 {mcpackagenamespaceget in class setup} -setup { + namespace eval bar { + oo::class create ClassCur + oo::define ClassCur variable a + } + } -cleanup { + namespace delete bar + } -body { + oo::define bar::ClassCur msgcat::mcpackagenamespaceget + } -result ::msgcat::test::bar + + test msgcat-16.3 {mcpackagenamespaceget in class} -setup { + namespace eval bar { + oo::class create ClassCur + oo::define ClassCur method method1 {} {msgcat::mcpackagenamespaceget} + } + namespace eval baz { + set ObjCur [::msgcat::test::bar::ClassCur new] + } + } -cleanup { + namespace delete bar baz + } -body { + $baz::ObjCur method1 + } -result ::msgcat::test::bar + + test msgcat-16.4 {mcpackagenamespaceget in classless object} -setup { + namespace eval bar { + oo::object create ObjCur + oo::objdefine ObjCur method method1 {} {msgcat::mcpackagenamespaceget} + } + } -cleanup { + namespace delete bar + } -body { + bar::ObjCur method1 + } -result ::msgcat::test::bar + + test msgcat-16.5\ + {mcpackagenamespaceget in classless object with explicite namespace eval}\ + -setup { + namespace eval bar { + oo::object create ObjCur + oo::objdefine ObjCur method method1 {} { + namespace eval ::msgcat::test::baz { + msgcat::mcpackagenamespaceget + } + } + } + } -cleanup { + namespace delete bar baz + } -body { + bar::ObjCur method1 + } -result ::msgcat::test::baz + + + # Test msgcat-17.*: mcn command + + test msgcat-17.1 {mcn no parameters} -body { + mcn + } -returnCodes 1\ + -result {wrong # args: should be "mcn ns src ?arg ...?"} + + test msgcat-17.2 {mcn} -setup { + namespace eval bar {::msgcat::mcset foo_BAR con1 con1bar} + variable locale [mclocale] + mclocale foo_BAR + } -cleanup { + mclocale $locale + } -body { + ::msgcat::mcn [namespace current]::bar con1 + } -result con1bar + + interp bgerror {} $bgerrorsaved + # Tests msgcat-15.*: [mcutil] + + test msgcat-15.1 {mcutil - no argument} -body { + mcutil + } -returnCodes 1\ + -result {wrong # args: should be "mcutil subcommand ?arg ...?"} + + test msgcat-15.2 {mcutil - wrong argument} -body { + mcutil junk + } -returnCodes 1\ + -result {unknown subcommand "junk": must be getpreferences, or getsystemlocale} + + test msgcat-15.3 {mcutil - partial argument} -body { + mcutil getsystem + } -returnCodes 1\ + -result {unknown subcommand "getsystem": must be getpreferences, or getsystemlocale} + + test msgcat-15.4 {mcutil getpreferences - no argument} -body { + mcutil getpreferences + } -returnCodes 1\ + -result {wrong # args: should be "mcutil getpreferences locale"} + + test msgcat-15.5 {mcutil getpreferences - DE_de} -body { + mcutil getpreferences DE_de + } -result {de_de de {}} + + test msgcat-15.6 {mcutil getsystemlocale - wrong argument} -body { + mcutil getsystemlocale DE_de + } -returnCodes 1\ + -result {wrong # args: should be "mcutil getsystemlocale"} + + # The result is system dependent + # So just test if it runs + # The environment variable version was test with test 0.x + test msgcat-15.7 {mcutil getsystemlocale} -body { + mcutil getsystemlocale + set ok ok + } -result {ok} + + cleanupTests } namespace delete ::msgcat::test diff --git a/tests/oo.test b/tests/oo.test index 4f9490b..2d23a3c 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -13,6 +13,13 @@ if {"::tcltest" in [namespace children]} { namespace import -force ::tcltest::* } + +# The foundational objects oo::object and oo::class are sensitive to reference +# counting errors and are deallocated only when an interp is deleted, so in +# this test suite, interp creation and interp deletion are often used in +# leaktests in order to leverage this sensitivity. + + testConstraint memory [llength [info commands memory]] if {[testConstraint memory]} { proc getbytes {} { @@ -57,7 +64,13 @@ test oo-0.4 {basic test of OO's ability to clean up its initial state} -body { foo destroy } } -constraints memory -result 0 -test oo-0.5 {testing literal leak on interp delete} memory { +test oo-0.5.1 {testing object foundation cleanup} memory { + leaktest { + interp create foo + interp delete foo + } +} 0 +test oo-0.5.2 {testing literal leak on interp delete} memory { leaktest { interp create foo foo eval {oo::object new} @@ -265,7 +278,21 @@ test oo-1.18 {OO: create object in NS with same name as global cmd} -setup { rename test-oo-1.18 {} A destroy } -result ::C -test oo-1.18.1 {Bug 75b8433707: memory leak in oo-1.18} -setup { +test oo-1.18.1 {no memory leak: superclass} -setup { +} -constraints memory -body { + + leaktest { + interp create t + t eval { + oo::class create A { + superclass oo::class + } + } + interp delete t + } +} -cleanup { +} -result 0 +test oo-1.18.2 {Bug 75b8433707: memory leak in oo-1.18} -setup { proc test-oo-1.18 {} return } -constraints memory -body { leaktest { @@ -278,7 +305,7 @@ test oo-1.18.1 {Bug 75b8433707: memory leak in oo-1.18} -setup { } -cleanup { rename test-oo-1.18 {} } -result 0 -test oo-1.18.2 {Bug 21c144f0f5} -setup { +test oo-1.18.3 {Bug 21c144f0f5} -setup { interp create slave } -body { slave eval { @@ -1502,7 +1529,56 @@ test oo-11.5 {OO: cleanup} { return done } done -test oo-11.6 { +test oo-11.6.1 { + OO: cleanup of when an class is mixed into itself +} -constraints memory -body { + leaktest { + interp create interp1 + oo::class create obj1 + ::oo::define obj1 {self mixin [uplevel 1 {namespace which obj1}]} + rename obj1 {} + interp delete interp1 + } +} -result 0 -cleanup { +} + +test oo-11.6.2 { + OO: cleanup ReleaseClassContents() where class is mixed into one of its + instances +} -constraints memory -body { + leaktest { + interp create interp1 + interp1 eval { + oo::class create obj1 + ::oo::copy obj1 obj2 + rename obj2 {} + rename obj1 {} + } + interp delete interp1 + } +} -result 0 -cleanup { +} + +test oo-11.6.3 { + OO: cleanup ReleaseClassContents() where class is mixed into one of its + instances +} -constraints memory -body { + leaktest { + interp create interp1 + interp1 eval { + oo::class create obj1 + ::oo::define obj1 {self mixin [uplevel 1 {namespace which obj1}]} + + ::oo::copy obj1 obj2 + rename obj2 {} + rename obj1 {} + } + interp delete interp1 + } +} -result 0 -cleanup { +} + +test oo-11.6.4 { OO: cleanup ReleaseClassContents() where class is mixed into one of its instances } -body { @@ -2065,7 +2141,20 @@ test oo-15.12 {OO: object cloning with target NS} -setup { Super destroy catch {namespace delete ::existing} } -result {::existing refers to an existing namespace} -test oo-15.13 {OO: object cloning with target NS} -setup { +test oo-15.13.1 { + OO: object cloning with target NS + Valgrind will report a leak if the reference count of the namespace isn't + properly incremented. +} -setup { + oo::class create Cls {} +} -body { + oo::copy Cls Cls2 ::dupens + return done +} -cleanup { + Cls destroy + Cls2 destroy +} -result done +test oo-15.13.2 {OO: object cloning with target NS} -setup { oo::class create Super oo::class create Cls {superclass Super} } -body { @@ -3661,99 +3750,110 @@ test oo-31.2 {Bug 3111059: when objects and coroutines entangle} -setup { cls destroy } -result {0 {}} -oo::class create SampleSlot { - superclass oo::Slot - constructor {} { - variable contents {a b c} ops {} - } - method contents {} {variable contents; return $contents} - method ops {} {variable ops; return $ops} - method Get {} { - variable contents - variable ops - lappend ops [info level] Get - return $contents - } - method Set {lst} { - variable contents $lst - variable ops - lappend ops [info level] Set $lst - return +proc SampleSlotSetup script { + set script0 { + oo::class create SampleSlot { + superclass oo::Slot + constructor {} { + variable contents {a b c} ops {} + } + method contents {} {variable contents; return $contents} + method ops {} {variable ops; return $ops} + method Get {} { + variable contents + variable ops + lappend ops [info level] Get + return $contents + } + method Set {lst} { + variable contents $lst + variable ops + lappend ops [info level] Set $lst + return + } + } } + append script0 \n$script } -test oo-32.1 {TIP 380: slots - class test} -setup { +proc SampleSlotCleanup script { + set script0 { + SampleSlot destroy + } + append script \n$script0 +} + +test oo-32.1 {TIP 380: slots - class test} -setup [SampleSlotSetup { SampleSlot create sampleSlot -} -body { +}] -body { list [info level] [sampleSlot contents] [sampleSlot ops] -} -cleanup { +} -cleanup [SampleSlotCleanup { rename sampleSlot {} -} -result {0 {a b c} {}} -test oo-32.2 {TIP 380: slots - class test} -setup { +}] -result {0 {a b c} {}} +test oo-32.2 {TIP 380: slots - class test} -setup [SampleSlotSetup { SampleSlot create sampleSlot -} -body { +}] -body { list [info level] [sampleSlot -clear] \ [sampleSlot contents] [sampleSlot ops] -} -cleanup { +} -cleanup [SampleSlotCleanup { rename sampleSlot {} -} -result {0 {} {} {1 Set {}}} -test oo-32.3 {TIP 380: slots - class test} -setup { +}] -result {0 {} {} {1 Set {}}} +test oo-32.3 {TIP 380: slots - class test} -setup [SampleSlotSetup { SampleSlot create sampleSlot -} -body { +}] -body { list [info level] [sampleSlot -append g h i] \ [sampleSlot contents] [sampleSlot ops] -} -cleanup { +} -cleanup [SampleSlotCleanup { rename sampleSlot {} -} -result {0 {} {a b c g h i} {1 Get 1 Set {a b c g h i}}} -test oo-32.4 {TIP 380: slots - class test} -setup { +}] -result {0 {} {a b c g h i} {1 Get 1 Set {a b c g h i}}} +test oo-32.4 {TIP 380: slots - class test} -setup [SampleSlotSetup { SampleSlot create sampleSlot -} -body { +}] -body { list [info level] [sampleSlot -set d e f] \ [sampleSlot contents] [sampleSlot ops] -} -cleanup { +} -cleanup [SampleSlotCleanup { rename sampleSlot {} -} -result {0 {} {d e f} {1 Set {d e f}}} -test oo-32.5 {TIP 380: slots - class test} -setup { +}] -result {0 {} {d e f} {1 Set {d e f}}} +test oo-32.5 {TIP 380: slots - class test} -setup [SampleSlotSetup { SampleSlot create sampleSlot -} -body { +}] -body { list [info level] [sampleSlot -set d e f] [sampleSlot -append g h i] \ [sampleSlot contents] [sampleSlot ops] -} -cleanup { +} -cleanup [SampleSlotCleanup { rename sampleSlot {} -} -result {0 {} {} {d e f g h i} {1 Set {d e f} 1 Get 1 Set {d e f g h i}}} +}] -result {0 {} {} {d e f g h i} {1 Set {d e f} 1 Get 1 Set {d e f g h i}}} -test oo-33.1 {TIP 380: slots - defaulting} -setup { +test oo-33.1 {TIP 380: slots - defaulting} -setup [SampleSlotSetup { set s [SampleSlot new] -} -body { +}] -body { list [$s x y] [$s contents] -} -cleanup { +} -cleanup [SampleSlotCleanup { rename $s {} -} -result {{} {a b c x y}} -test oo-33.2 {TIP 380: slots - defaulting} -setup { +}] -result {{} {a b c x y}} +test oo-33.2 {TIP 380: slots - defaulting} -setup [SampleSlotSetup { set s [SampleSlot new] -} -body { +}] -body { list [$s destroy; $s unknown] [$s contents] -} -cleanup { +} -cleanup [SampleSlotCleanup { rename $s {} -} -result {{} {a b c destroy unknown}} -test oo-33.3 {TIP 380: slots - defaulting} -setup { +}] -result {{} {a b c destroy unknown}} +test oo-33.3 {TIP 380: slots - defaulting} -setup [SampleSlotSetup { set s [SampleSlot new] -} -body { +}] -body { oo::objdefine $s forward --default-operation my -set list [$s destroy; $s unknown] [$s contents] [$s ops] -} -cleanup { +} -cleanup [SampleSlotCleanup { rename $s {} -} -result {{} unknown {1 Set destroy 1 Set unknown}} -test oo-33.4 {TIP 380: slots - errors} -setup { +}] -result {{} unknown {1 Set destroy 1 Set unknown}} +test oo-33.4 {TIP 380: slots - errors} -setup [SampleSlotSetup { set s [SampleSlot new] -} -body { +}] -body { # Method names beginning with "-" are special to slots $s -grill q -} -returnCodes error -cleanup { +} -returnCodes error -cleanup [SampleSlotCleanup { rename $s {} -} -result {unknown method "-grill": must be -append, -clear, -set, contents or ops} - -SampleSlot destroy +}] -result \ + {unknown method "-grill": must be -append, -clear, -set, contents or ops} test oo-34.1 {TIP 380: slots - presence} -setup { set obj [oo::object new] diff --git a/tests/process.test b/tests/process.test new file mode 100644 index 0000000..fb3a5e2 --- /dev/null +++ b/tests/process.test @@ -0,0 +1,31 @@ +# process.test -- +# +# This file contains a collection of tests for the tcl::process ensemble. +# Sourcing this file into Tcl runs the tests and generates output for +# errors. No output means no errors were found. +# +# Copyright (c) 2017 Frederic Bonnet +# See the file "license.terms" for information on usage and redistribution of +# this file, and for a DISCLAIMER OF ALL WARRANTIES. + +if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest 2 + namespace import -force ::tcltest::* +} + +test process-1.1 {tcl::process command basic syntax} -returnCodes error -body { + tcl::process +} -result {wrong # args: should be "tcl::process subcommand ?arg ...?"} +test process-1.2 {tcl::process command basic syntax} -returnCodes error -body { + tcl::process ? +} -match glob -result {unknown or ambiguous subcommand "?": must be autopurge, list, purge, or status} + +test process-2.1 {tcl::process autopurge get} {tcl::process autopurge} {1} +test process-2.2 {tcl::process autopurge set true} { + tcl::process autopurge true + tcl::process autopurge +} {1} +test process-2.3 {tcl::process autopurge set false} { + tcl::process autopurge false + tcl::process autopurge +} {0} diff --git a/tests/string.test b/tests/string.test index 60b3177..f4b94de 100644 --- a/tests/string.test +++ b/tests/string.test @@ -1393,6 +1393,9 @@ test string-14.17 {string replace} { test string-14.18 {string replace} { string replace abcdefghijklmnop 10 9 XXX } {abcdefghijklmnop} +test string-14.19 {string replace} { + string replace {} -1 0 A +} A test string-15.1 {string tolower too few args} { list [catch {string tolower} msg] $msg diff --git a/unix/Makefile.in b/unix/Makefile.in index 244ad29..83a8aed 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -303,7 +303,7 @@ GENERIC_OBJS = regcomp.o regexec.o regfree.o regerror.o tclAlloc.o \ tclLiteral.o tclLoad.o tclMain.o tclNamesp.o tclNotify.o \ tclObj.o tclOptimize.o tclPanic.o tclParse.o tclPathObj.o tclPipe.o \ tclPkg.o tclPkgConfig.o tclPosixStr.o \ - tclPreserve.o tclProc.o tclRegexp.o \ + tclPreserve.o tclProc.o tclProcess.o tclRegexp.o \ tclResolve.o tclResult.o tclScan.o tclStringObj.o \ tclStrToD.o tclThread.o \ tclThreadAlloc.o tclThreadJoin.o tclThreadStorage.o tclStubInit.o \ @@ -444,6 +444,7 @@ GENERIC_SRCS = \ $(GENERIC_DIR)/tclPosixStr.c \ $(GENERIC_DIR)/tclPreserve.c \ $(GENERIC_DIR)/tclProc.c \ + $(GENERIC_DIR)/tclProcess.c \ $(GENERIC_DIR)/tclRegexp.c \ $(GENERIC_DIR)/tclResolve.c \ $(GENERIC_DIR)/tclResult.c \ @@ -850,8 +851,8 @@ install-libraries: libraries do \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/opt0.4; \ done; - @echo "Installing package msgcat 1.6.1 as a Tcl Module"; - @$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/msgcat-1.6.1.tm; + @echo "Installing package msgcat 1.7.0 as a Tcl Module"; + @$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.7/msgcat-1.7.0.tm; @echo "Installing package tcltest 2.4.1 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.4.1.tm; @@ -1288,6 +1289,9 @@ tclPreserve.o: $(GENERIC_DIR)/tclPreserve.c tclProc.o: $(GENERIC_DIR)/tclProc.c $(COMPILEHDR) $(NREHDR) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclProc.c +tclProcess.o: $(GENERIC_DIR)/tclProcess.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclProcess.c + tclRegexp.o: $(GENERIC_DIR)/tclRegexp.c $(TCLREHDRS) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclRegexp.c diff --git a/win/Makefile.in b/win/Makefile.in index 5be7492..56ccb4d 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -285,6 +285,7 @@ GENERIC_OBJS = \ tclPosixStr.$(OBJEXT) \ tclPreserve.$(OBJEXT) \ tclProc.$(OBJEXT) \ + tclProcess.$(OBJEXT) \ tclRegexp.$(OBJEXT) \ tclResolve.$(OBJEXT) \ tclResult.$(OBJEXT) \ @@ -659,8 +660,8 @@ install-libraries: libraries install-tzdata install-msgs do \ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/opt0.4"; \ done; - @echo "Installing package msgcat 1.6.1 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/msgcat-1.6.1.tm; + @echo "Installing package msgcat 1.7.0 as a Tcl Module"; + @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.7/msgcat-1.7.0.tm; @echo "Installing package tcltest 2.4.0 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/tcltest-2.4.0.tm; @echo "Installing package platform 1.0.14 as a Tcl Module"; diff --git a/win/buildall.vc.bat b/win/buildall.vc.bat index deb9e39..cb136be 100644 --- a/win/buildall.vc.bat +++ b/win/buildall.vc.bat @@ -38,7 +38,9 @@ if defined WINDOWSSDKDIR (goto :startBuilding) :: might not be correct. You should call it yourself prior to running
:: this batchfile.
::
-call "C:\Program Files\Microsoft Developer Studio\vc98\bin\vcvars32.bat"
+REM call "C:\Program Files\Microsoft Developer Studio\vc98\bin\vcvars32.bat"
+set "VSCMD_START_DIR=%CD%"
+call "C:\Program Files (x86)\Microsoft Visual Studio\2017\Community\Common7\Tools\VsDevCmd.bat"
if errorlevel 1 (goto no_vcvars)
:startBuilding
diff --git a/win/makefile.vc b/win/makefile.vc index 64717af..7ed4c63 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -218,6 +218,7 @@ COREOBJS = \ $(TMP_DIR)\tclPosixStr.obj \ $(TMP_DIR)\tclPreserve.obj \ $(TMP_DIR)\tclProc.obj \ + $(TMP_DIR)\tclProcess.obj \ $(TMP_DIR)\tclRegexp.obj \ $(TMP_DIR)\tclResolve.obj \ $(TMP_DIR)\tclResult.obj \ @@ -868,7 +869,7 @@ install-libraries: tclConfig tcl-nmake install-msgs install-tzdata "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.6\http-$(PKG_HTTP_VER).tm" @echo Installing package msgcat $(PKG_MSGCAT_VER) as a Tcl Module @$(COPY) "$(ROOT)\library\msgcat\msgcat.tcl" \ - "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.5\msgcat-$(PKG_MSGCAT_VER).tm" + "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.7\msgcat-$(PKG_MSGCAT_VER).tm" @echo Installing package tcltest $(PKG_TCLTEST_VER) as a Tcl Module @$(COPY) "$(ROOT)\library\tcltest\tcltest.tcl" \ "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.5\tcltest-$(PKG_TCLTEST_VER).tm" diff --git a/win/tcl.dsp b/win/tcl.dsp index ad9c764..ab9ec26 100644 --- a/win/tcl.dsp +++ b/win/tcl.dsp @@ -1264,6 +1264,10 @@ SOURCE=..\generic\tclProc.c # End Source File
# Begin Source File
+SOURCE=..\generic\tclProcess.c
+# End Source File
+# Begin Source File
+
SOURCE=..\generic\tclRegexp.c
# End Source File
# Begin Source File
diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c index d1b0596..a357412 100644 --- a/win/tclWinPipe.c +++ b/win/tclWinPipe.c @@ -869,7 +869,7 @@ TclpGetPid( Tcl_MutexLock(&pipeMutex); for (infoPtr = procList; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { - if (infoPtr->hProcess == (HANDLE) pid) { + if (infoPtr->dwProcessId == (DWORD) pid) { Tcl_MutexUnlock(&pipeMutex); return infoPtr->dwProcessId; } @@ -1163,7 +1163,7 @@ TclpCreateProcess( WaitForInputIdle(procInfo.hProcess, 5000); CloseHandle(procInfo.hThread); - *pidPtr = (Tcl_Pid) procInfo.hProcess; + *pidPtr = (Tcl_Pid) procInfo.dwProcessId; if (*pidPtr != 0) { TclWinAddProcess(procInfo.hProcess, procInfo.dwProcessId); } @@ -2347,7 +2347,7 @@ Tcl_WaitPid( prevPtrPtr = &procList; for (infoPtr = procList; infoPtr != NULL; prevPtrPtr = &infoPtr->nextPtr, infoPtr = infoPtr->nextPtr) { - if (infoPtr->hProcess == (HANDLE) pid) { + if (infoPtr->dwProcessId == (DWORD) pid) { *prevPtrPtr = infoPtr->nextPtr; break; } |