summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordgp <dgp@users.sourceforge.net>2018-03-15 14:23:18 (GMT)
committerdgp <dgp@users.sourceforge.net>2018-03-15 14:23:18 (GMT)
commitbe8b7d25f6ed27943242888bf395ea2aa50632ae (patch)
treee7faf7871cc0c0180df22b5903d708fba0a73a9c
parent0bef3861ff2e6a20bb908d6099a1b55ff80860e8 (diff)
parentaa199edba612a516e6309290fb6dc4442a49a5ee (diff)
downloadtcl-be8b7d25f6ed27943242888bf395ea2aa50632ae.zip
tcl-be8b7d25f6ed27943242888bf395ea2aa50632ae.tar.gz
tcl-be8b7d25f6ed27943242888bf395ea2aa50632ae.tar.bz2
merge 8.7
-rw-r--r--changes5
-rw-r--r--doc/msgcat.n205
-rw-r--r--generic/tclBasic.c1
-rw-r--r--generic/tclCmdMZ.c47
-rw-r--r--generic/tclCompCmdsSZ.c240
-rw-r--r--generic/tclExecute.c109
-rw-r--r--generic/tclInt.h29
-rw-r--r--generic/tclOO.c249
-rw-r--r--generic/tclOODefineCmds.c73
-rw-r--r--generic/tclPipe.c78
-rw-r--r--generic/tclProcess.c952
-rw-r--r--generic/tclStringObj.c145
-rw-r--r--generic/tclUtil.c255
-rw-r--r--library/msgcat/msgcat.tcl300
-rw-r--r--library/msgcat/pkgIndex.tcl4
-rw-r--r--tests/coroutine.test2
-rw-r--r--tests/foreach.test6
-rw-r--r--tests/ioCmd.test4
-rw-r--r--tests/ioTrans.test2
-rw-r--r--tests/msgcat.test292
-rw-r--r--tests/oo.test222
-rw-r--r--tests/process.test31
-rw-r--r--tests/string.test3
-rw-r--r--unix/Makefile.in10
-rw-r--r--win/Makefile.in5
-rw-r--r--win/buildall.vc.bat4
-rw-r--r--win/makefile.vc3
-rw-r--r--win/tcl.dsp4
-rw-r--r--win/tclWinPipe.c6
29 files changed, 2580 insertions, 706 deletions
diff --git a/changes b/changes
index f89704b..01d4c7a 100644
--- a/changes
+++ b/changes
@@ -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;
}