Tcl Source Code

Check-in [16cda61498]
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to [email protected]
or submit via the online form by Sep 9.

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:merge 8.7
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | tip-421
Files: files | file ages | folders
SHA3-256: 16cda614982b50c85373c78dbe18e27a2e7632efbffeba19a76dd53d75a6a86a
User & Date: dgp 2018-03-15 14:18:39
Context
2018-04-11
12:45
merge 8.7 check-in: 43e01830a9 user: dgp tags: tip-421
2018-03-15
14:18
merge 8.7 check-in: 16cda61498 user: dgp tags: tip-421
11:08
merge 8.6 check-in: ff4b8f1a06 user: dgp tags: core-8-branch
2018-03-11
22:34
merge 8.7 check-in: c5126a3728 user: dgp tags: tip-421
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Changes to changes.

  8875   8875   2017-06-23 (TIP 472) Support 0d as prefix of decimal numbers (iyer,griffin)
  8876   8876   
  8877   8877   2017-08-31 (bug)[2a9465] http state 100 continue handling broken (oehlmann)
  8878   8878   
  8879   8879   2017-09-02 (bug)[0e4d88] replace command, delete trace kills namespace (porter)
  8880   8880   
  8881   8881   --- Released 8.7a1, September 8, 2017 --- http://core.tcl.tk/tcl/ for details
         8882  +
         8883  +2018-03-12 (TIP 490) add oo support for msgcat => msgcat 1.7.0 (oehlmann)
         8884  +
         8885  +2018-03-12 (TIP 499) custom locale preference list (oehlmann)
         8886  +=> msgcat 1.7.0

Changes to doc/msgcat.n.

     7      7   .TH "msgcat" n 1.5 msgcat "Tcl Bundled Packages"
     8      8   .so man.macros
     9      9   .BS
    10     10   '\" Note:  do not modify the .SH NAME line immediately below!
    11     11   .SH NAME
    12     12   msgcat \- Tcl message catalog
    13     13   .SH SYNOPSIS
    14         -\fBpackage require Tcl 8.5\fR
           14  +\fBpackage require Tcl 8.7\fR
    15     15   .sp
    16         -\fBpackage require msgcat 1.6\fR
           16  +\fBpackage require msgcat 1.7\fR
    17     17   .sp
    18     18   \fB::msgcat::mc \fIsrc-string\fR ?\fIarg arg ...\fR?
    19     19   .sp
    20     20   \fB::msgcat::mcmax ?\fIsrc-string src-string ...\fR?
    21     21   .sp
    22     22   .VS "TIP 412"
    23     23   \fB::msgcat::mcexists\fR ?\fB-exactnamespace\fR? ?\fB-exactlocale\fR? \fIsrc-string\fR
    24     24   .VE "TIP 412"
           25  +.sp
           26  +.VS "TIP 490"
           27  +\fB::msgcat::mcpackagenamespaceget\fR
           28  +.VE "TIP 490"
    25     29   .sp
    26     30   \fB::msgcat::mclocale \fR?\fInewLocale\fR?
    27     31   .sp
    28         -\fB::msgcat::mcpreferences\fR
           32  +.VS "TIP 499"
           33  +\fB::msgcat::mcpreferences\fR ?\fIlocale preference\fR? ...
           34  +.VE "TIP 499"
    29     35   .sp
    30     36   .VS "TIP 412"
    31     37   \fB::msgcat::mcloadedlocales subcommand\fR ?\fIlocale\fR?
    32     38   .VE "TIP 412"
    33     39   .sp
    34     40   \fB::msgcat::mcload \fIdirname\fR
    35     41   .sp
................................................................................
    46     52   .VS "TIP 412"
    47     53   \fB::msgcat::mcpackagelocale subcommand\fR ?\fIlocale\fR?
    48     54   .sp
    49     55   \fB::msgcat::mcpackageconfig subcommand\fR \fIoption\fR ?\fIvalue\fR?
    50     56   .sp
    51     57   \fB::msgcat::mcforgetpackage\fR
    52     58   .VE "TIP 412"
           59  +.sp
           60  +.VS "TIP 499"
           61  +\fB::msgcat::mcutil subcommand\fR ?\fIlocale\fR?
           62  +.VS "TIP 499"
    53     63   .BE
    54     64   .SH DESCRIPTION
    55     65   .PP
    56     66   The \fBmsgcat\fR package provides a set of functions
    57     67   that can be used to manage multi-lingual user interfaces.
    58     68   Text strings are defined in a
    59     69   .QW "message catalog"
................................................................................
    67     77   Each package has its own message catalog and configuration settings in \fBmsgcat\fR.
    68     78   .PP
    69     79   A \fIlocale\fR is a specification string describing a user language like \fBde_ch\fR for Swiss German.
    70     80   In \fBmsgcat\fR, there is a global locale initialized by the system locale of the current system.
    71     81   Each package may decide to use the global locale or to use a package specific locale.
    72     82   .PP
    73     83   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.
           84  +.PP
           85  +.VS tip490
           86  +Object oriented programming is supported by the use of a package namespace.
           87  +.VE tip490
           88  +.PP
    74     89   .SH COMMANDS
    75     90   .TP
    76     91   \fB::msgcat::mc \fIsrc-string\fR ?\fIarg arg ...\fR?
    77     92   .
    78     93   Returns a translation of \fIsrc-string\fR according to the
    79     94   current locale.  If additional arguments past \fIsrc-string\fR
    80     95   are given, the \fBformat\fR command is used to substitute the
................................................................................
    91    106   \fB::msgcat::mc\fR is the main function used to localize an
    92    107   application.  Instead of using an English string directly, an
    93    108   application can pass the English string through \fB::msgcat::mc\fR and
    94    109   use the result.  If an application is written for a single language in
    95    110   this fashion, then it is easy to add support for additional languages
    96    111   later simply by defining new message catalog entries.
    97    112   .RE
          113  +.VS "TIP 490"
          114  +.TP
          115  +\fB::msgcat::mcn \fInamespace\fR \fIsrc-string\fR ?\fIarg arg ...\fR?
          116  +.
          117  +Like \fB::msgcat::mc\fR, but with the message namespace specified as first argument.
          118  +.PP
          119  +.RS
          120  +\fBmcn\fR may be used for cases where the package namespace is not the namespace of the caller.
          121  +An example is shown within the description of the command \fB::msgcat::mcpackagenamespaceget\fR below.
          122  +.RE
          123  +.PP
    98    124   .TP
    99    125   \fB::msgcat::mcmax ?\fIsrc-string src-string ...\fR?
   100    126   .
   101    127   Given several source strings, \fB::msgcat::mcmax\fR returns the length
   102    128   of the longest translated string.  This is useful when designing
   103    129   localized GUIs, which may require that all buttons, for example, be a
   104    130   fixed width (which will be the width of the widest button).
   105    131   .TP
   106         -\fB::msgcat::mcexists\fR ?\fB-exactnamespace\fR? ?\fB-exactlocale\fR? \fIsrc-string\fR
   107         -.
   108    132   .VS "TIP 412"
          133  +\fB::msgcat::mcexists\fR ?\fB-exactnamespace\fR? ?\fB-exactlocale\fR? ?\fB-namespace\fR \fInamespace\fR? \fIsrc-string\fR
          134  +.
   109    135   Return true, if there is a translation for the given \fIsrc-string\fR.
   110    136   .PP
   111    137   .RS
   112    138   The search may be limited by the option \fB\-exactnamespace\fR to only check the current namespace and not any parent namespaces.
   113    139   .PP
   114    140   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).
   115         -.RE
          141  +.PP
   116    142   .VE "TIP 412"
          143  +.VS "TIP 490"
          144  +An explicit package namespace may be specified by the option \fB-namespace\fR.
          145  +The namespace of the caller is used if not explicitly specified.
          146  +.RE
          147  +.PP
          148  +.VE "TIP 490"
          149  +.VS "TIP 490"
          150  +.TP
          151  +\fB::msgcat::mcpackagenamespaceget\fR
          152  +.
          153  +Return the package namespace of the caller.
          154  +This command handles all cases described in section \fBOBJECT ORIENTED PROGRAMMING\fR.
          155  +.PP
          156  +.RS
          157  +Example usage is a tooltip package, which saves the caller package namespace to update the translation each time the tooltip is shown:
          158  +.CS
          159  +proc ::tooltip::tooltip {widget message} {
          160  +    ...
          161  +    set messagenamespace [uplevel 1 {::msgcat::mcpackagenamespaceget}]
          162  +    ...
          163  +    bind $widget  [list ::tooltip::show $widget $messagenamespace $message]
          164  +}
          165  +
          166  +proc ::tooltip::show {widget messagenamespace message} {
          167  +    ...
          168  +    set message [::msgcat::mcn $messagenamespace $message]
          169  +    ...
          170  +}
          171  +.CE
          172  +.RE
          173  +.PP
          174  +.VE "TIP 490"
   117    175   .TP
   118    176   \fB::msgcat::mclocale \fR?\fInewLocale\fR?
   119    177   .
   120         -This function sets the locale to \fInewLocale\fR.  If \fInewLocale\fR
   121         -is omitted, the current locale is returned, otherwise the current locale
   122         -is set to \fInewLocale\fR.  msgcat stores and compares the locale in a
          178  +If \fInewLocale\fR is omitted, the current locale is returned, otherwise the current locale
          179  +is set to \fInewLocale\fR.
          180  +.PP
          181  +.RS
          182  +If the new locale is set to \fInewLocale\fR, the corresponding preferences are calculated and set.
          183  +For example, if the current locale is en_US_funky, then \fB::msgcat::mcpreferences\fR returns \fB{en_us_funky en_us en {}}\fR.
          184  +.PP
          185  +The same result may be acheved by \fB::msgcat::mcpreferences\fR {*}[\fB::msgcat::mcutil getpreferences\fR \fInewLocale\fR].
          186  +.PP
          187  +The current locale is always the first element of the list returned by \fBmcpreferences\fR.
          188  +.PP
          189  +msgcat stores and compares the locale in a
   123    190   case-insensitive manner, and returns locales in lowercase.
   124    191   The initial locale is determined by the locale specified in
   125    192   the user's environment.  See \fBLOCALE SPECIFICATION\fR
   126    193   below for a description of the locale string format.
   127         -.RS
   128    194   .PP
   129    195   .VS "TIP 412"
   130    196   If the locale is set, the preference list of locales is evaluated.
   131    197   Locales in this list are loaded now, if not jet loaded.
   132    198   .VE "TIP 412"
   133    199   .RE
   134    200   .TP
   135         -\fB::msgcat::mcpreferences\fR
          201  +\fB::msgcat::mcpreferences\fR ?\fIlocale preference\fR? ...
   136    202   .
   137         -Returns an ordered list of the locales preferred by
   138         -the user, based on the user's language specification.
   139         -The list is ordered from most specific to least
   140         -preference.  The list is derived from the current
   141         -locale set in msgcat by \fB::msgcat::mclocale\fR, and
   142         -cannot be set independently.  For example, if the
   143         -current locale is en_US_funky, then \fB::msgcat::mcpreferences\fR
   144         -returns \fB{en_us_funky en_us en {}}\fR.
          203  +Without arguments, returns an ordered list of the locales preferred by
          204  +the user.
          205  +The list is ordered from most specific to least preference.
          206  +.PP
          207  +.VS "TIP 499"
          208  +.RS
          209  +A set of locale preferences may be given to set the list of locale preferences.
          210  +The current locale is also set, which is the first element of the locale preferences list.
          211  +.PP
          212  +Locale preferences are loaded now, if not jet loaded.
          213  +.PP
          214  +As an example, the user may prefer French or English text. This may be configured by:
          215  +.CS
          216  +::msgcat::mcpreferences fr en {}
          217  +.CE
          218  +.RE
          219  +.PP
          220  +.VS "TIP 499"
   145    221   .TP
   146    222   \fB::msgcat:mcloadedlocales subcommand\fR ?\fIlocale\fR?
   147    223   .
   148    224   This group of commands manage the list of loaded locales for packages not setting a package locale.
   149    225   .PP
   150    226   .RS
   151    227   The subcommand \fBget\fR returns the list of currently loaded locales.
................................................................................
   227    303   Note that this routine is only called if the concerned package did not set a package locale unknown command name.
   228    304   .RE
   229    305   .TP
   230    306   \fB::msgcat::mcforgetpackage\fR
   231    307   .
   232    308   The calling package clears all its state within the \fBmsgcat\fR package including all settings and translations.
   233    309   .VE "TIP 412"
          310  +.PP
          311  +.VS "TIP 499"
          312  +.TP
          313  +\fB::msgcat::mcutil getpreferences\fR \fIlocale\fR
          314  +.
          315  +Return the preferences list of the given locale as described in section \fBLOCALE SPECIFICATION\fR.
          316  +An example is the composition of a preference list for the bilingual region "Biel/Bienne" as a concatenation of swiss german and swiss french:
          317  +.CS
          318  +% concat [lrange [msgcat::mcutil getpreferences fr_CH] 0 end-1] [msgcat::mcutil getpreferences de_CH]
          319  +fr_ch fr de_ch de {}
          320  +.CE
          321  +.TP
          322  +\fB::msgcat::mcutil getsystemlocale\fR
          323  +.
          324  +The system locale is returned as described by the section \fBLOCALE SPECIFICATION\fR.
          325  +.VE "TIP 499"
   234    326   .PP
   235    327   .SH "LOCALE SPECIFICATION"
   236    328   .PP
   237    329   The locale is specified to \fBmsgcat\fR by a locale string
   238    330   passed to \fB::msgcat::mclocale\fR.
   239    331   The locale string consists of
   240    332   a language code, an optional country code, and an optional
................................................................................
   433    525   .PP
   434    526   .CS
   435    527   \fBmsgcat::mc\fR {Produced %1$d at %2$s} $num $city
   436    528   # ... where that key is mapped to one of the
   437    529   # human-oriented versions by \fBmsgcat::mcset\fR
   438    530   .CE
   439    531   .VS "TIP 412"
   440         -.SH Package private locale
          532  +.SH "PACKAGE PRIVATE LOCALE"
   441    533   .PP
   442    534   A package using \fBmsgcat\fR may choose to use its own package private
   443    535   locale and its own set of loaded locales, independent to the global
   444    536   locale set by \fB::msgcat::mclocale\fR.
   445    537   .PP
   446    538   This allows a package to change its locale without causing any locales load or removal in other packages and not to invoke the global locale change callback (see below).
   447    539   .PP
................................................................................
   457    549   This command may cause the load of locales.
   458    550   .RE
   459    551   .TP
   460    552   \fB::msgcat::mcpackagelocale get\fR
   461    553   .
   462    554   Return the package private locale or the global locale, if no package private locale is set.
   463    555   .TP
   464         -\fB::msgcat::mcpackagelocale preferences\fR
          556  +\fB::msgcat::mcpackagelocale preferences\fR ?\fIlocale preference\fR? ...
   465    557   .
   466         -Return the package private preferences or the global preferences,
          558  +With no parameters, return the package private preferences or the global preferences,
   467    559   if no package private locale is set.
          560  +The package locale state (set or not) is not changed (in contrast to the command \fB::msgcat::mcpackagelocale set\fR).
          561  +.PP
          562  +.RS
          563  +.VS "TIP 499"
          564  +If a set of locale preferences is given, it is set as package locale preference list.
          565  +The package locale is set to the first element of the preference list.
          566  +A package locale is activated, if it was not set so far.
          567  +.PP
          568  +Locale preferences are loaded now for the package, if not jet loaded.
          569  +.VE "TIP 499"
          570  +.RE
          571  +.PP
   468    572   .TP
   469    573   \fB::msgcat::mcpackagelocale loaded\fR
   470    574   .
   471    575   Return the list of locales loaded for this package.
   472    576   .TP
   473    577   \fB::msgcat::mcpackagelocale isset\fR
   474    578   .
................................................................................
   484    588   .
   485    589   Returns true, if the given locale is loaded for the package.
   486    590   .TP
   487    591   \fB::msgcat::mcpackagelocale clear\fR
   488    592   .
   489    593   Clear any loaded locales of the package not present in the package preferences.
   490    594   .PP
   491         -.SH Changing package options
          595  +.SH "CHANGING PACKAGE OPTIONS"
   492    596   .PP
   493    597   Each package using msgcat has a set of options within \fBmsgcat\fR.
   494    598   The package options are described in the next sectionPackage options.
   495    599   Each package option may be set or unset individually using the following ensemble:
   496    600   .TP
   497    601   \fB::msgcat::mcpackageconfig get\fR \fIoption\fR
   498    602   .
................................................................................
   559    663   The called procedure must return the formatted message which will finally be returned by msgcat::mc.
   560    664   .PP
   561    665   A generic unknown handler is used if set to the empty string. This consists in returning the key if no arguments are given. With given arguments, format is used to process the arguments.
   562    666   .PP
   563    667   See section \fBcallback invocation\fR below.
   564    668   The appended arguments are identical to \fB::msgcat::mcunknown\fR.
   565    669   .RE
   566         -.SS Callback invocation
          670  +.SH "Callback invocation"
   567    671   A package may decide to register one or multiple callbacks, as described above.
   568    672   .PP
   569    673   Callbacks are invoked, if:
   570    674   .PP
   571    675   1. the callback command is set,
   572    676   .PP
   573    677   2. the command is not the empty string,
   574    678   .PP
   575    679   3. the registering namespace exists.
   576    680   .PP
   577    681   If a called routine fails with an error, the \fBbgerror\fR routine for the interpreter is invoked after command completion.
   578    682   Only exception is the callback \fBunknowncmd\fR, where an error causes the invoking \fBmc\fR-command to fail with that error.
   579    683   .PP
   580         -.SS Examples
          684  +.VS tip490
          685  +.SH "OBJECT ORIENTED PROGRAMMING"
          686  +\fBmsgcat\fR supports packages implemented by object oriented programming.
          687  +Objects and classes should be defined within a package namespace.
          688  +.PP
          689  +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:
          690  +.PP
          691  +.TP
          692  +\fB1) In class definition script\fR
          693  +.
          694  +\fBmsgcat\fR command is called within a class definition script.
          695  +.CS
          696  +namespace eval ::N2 {
          697  +    mcload $dir/msgs
          698  +    oo::class create C1 {puts [mc Hi!]}
          699  +}
          700  +.CE
          701  +.PP
          702  +.TP
          703  +\fB2) method defined in a class\fR
          704  +.
          705  +\fBmsgcat\fR command is called from a method in an object and the method is defined in a class.
          706  +.CS
          707  +namespace eval ::N3Class {
          708  +    mcload $dir/msgs
          709  +    oo::class create C1
          710  +    oo::define C1 method m1 {
          711  +        puts [mc Hi!]
          712  +    }
          713  +}
          714  +.CE
          715  +.PP
          716  +.TP
          717  +\fB3) method defined in a classless object\fR
          718  +.
          719  +\fBmsgcat\fR command is called from a method of a classless object.
          720  +.CS
          721  +namespace eval ::N4 {
          722  +    mcload $dir/msgs
          723  +    oo::object create O1
          724  +    oo::objdefine O1 method m1 {} {
          725  +        puts [mc Hi!]
          726  +    }
          727  +}
          728  +.CE
          729  +.PP
          730  +.VE tip490
          731  +.SH EXAMPLES
   581    732   Packages which display a GUI may update their widgets when the global locale changes.
   582    733   To register to a callback, use:
   583    734   .CS
   584    735   namespace eval gui {
   585    736       msgcat::mcpackageconfig changecmd updateGUI
   586    737   
   587    738       proc updateGui args {
................................................................................
   639    790   }
   640    791   .CE
   641    792   .VE "TIP 412"
   642    793   .SH CREDITS
   643    794   .PP
   644    795   The message catalog code was developed by Mark Harrison.
   645    796   .SH "SEE ALSO"
   646         -format(n), scan(n), namespace(n), package(n)
          797  +format(n), scan(n), namespace(n), package(n), oo::class(n), oo::object
   647    798   .SH KEYWORDS
   648         -internationalization, i18n, localization, l10n, message, text, translation
          799  +internationalization, i18n, localization, l10n, message, text, translation, class, object
   649    800   .\" Local Variables:
   650    801   .\" mode: nroff
   651    802   .\" End:

Changes to generic/tclBasic.c.

   815    815       TclInitDictCmd(interp);
   816    816       TclInitEncodingCmd(interp);
   817    817       TclInitFileCmd(interp);
   818    818       TclInitInfoCmd(interp);
   819    819       TclInitNamespaceCmd(interp);
   820    820       TclInitStringCmd(interp);
   821    821       TclInitPrefixCmd(interp);
          822  +    TclInitProcessCmd(interp);
   822    823   
   823    824       /*
   824    825        * Register "clock" subcommands. These *do* go through
   825    826        * Tcl_CreateObjCommand, since they aren't in the global namespace and
   826    827        * involve ensembles.
   827    828        */
   828    829   

Changes to generic/tclCmdMZ.c.

  2301   2301   static int
  2302   2302   StringRplcCmd(
  2303   2303       ClientData dummy,		/* Not used. */
  2304   2304       Tcl_Interp *interp,		/* Current interpreter. */
  2305   2305       int objc,			/* Number of arguments. */
  2306   2306       Tcl_Obj *const objv[])	/* Argument objects. */
  2307   2307   {
  2308         -    Tcl_UniChar *ustring;
  2309         -    int first, last, length;
         2308  +    int first, last, length, end;
  2310   2309   
  2311   2310       if (objc < 4 || objc > 5) {
  2312   2311   	Tcl_WrongNumArgs(interp, 1, objv, "string first last ?string?");
  2313   2312   	return TCL_ERROR;
  2314   2313       }
  2315   2314   
  2316         -    ustring = Tcl_GetUnicodeFromObj(objv[1], &length);
  2317         -    length--;
         2315  +    length = Tcl_GetCharLength(objv[1]);
         2316  +    end = length - 1;
  2318   2317   
  2319         -    if (TclGetIntForIndexM(interp, objv[2], length, &first) != TCL_OK ||
  2320         -	    TclGetIntForIndexM(interp, objv[3], length, &last) != TCL_OK){
         2318  +    if (TclGetIntForIndexM(interp, objv[2], end, &first) != TCL_OK ||
         2319  +	    TclGetIntForIndexM(interp, objv[3], end, &last) != TCL_OK){
  2321   2320   	return TCL_ERROR;
  2322   2321       }
  2323   2322   
  2324         -    if ((last < first) || (last < 0) || (first > length)) {
         2323  +    /*
         2324  +     * The following test screens out most empty substrings as
         2325  +     * candidates for replacement. When they are detected, no
         2326  +     * replacement is done, and the result is the original string,
         2327  +     */
         2328  +    if ((last < 0) ||		/* Range ends before start of string */
         2329  +	    (first > end) ||	/* Range begins after end of string */
         2330  +	    (last < first)) {	/* Range begins after it starts */
         2331  +
         2332  +	/*
         2333  +	 * BUT!!! when (end < 0) -- an empty original string -- we can
         2334  +	 * have (first <= end < 0 <= last) and an empty string is permitted
         2335  +	 * to be replaced.
         2336  +	 */
  2325   2337   	Tcl_SetObjResult(interp, objv[1]);
  2326   2338       } else {
  2327   2339   	Tcl_Obj *resultPtr;
  2328   2340   
  2329         -	ustring = Tcl_GetUnicodeFromObj(objv[1], &length);
  2330         -	length--;
  2331         -
  2332   2341   	if (first < 0) {
  2333   2342   	    first = 0;
  2334   2343   	}
         2344  +	if (last > end) {
         2345  +	    last = end;
         2346  +	}
  2335   2347   
  2336         -	resultPtr = Tcl_NewUnicodeObj(ustring, first);
  2337         -	if (objc == 5) {
  2338         -	    Tcl_AppendObjToObj(resultPtr, objv[4]);
  2339         -	}
  2340         -	if (last < length) {
  2341         -	    Tcl_AppendUnicodeToObj(resultPtr, ustring + last + 1,
  2342         -		    length - last);
  2343         -	}
         2348  +	resultPtr = TclStringReplace(interp, objv[1], first,
         2349  +		last + 1 - first, (objc == 5) ? objv[4] : NULL,
         2350  +		TCL_STRING_IN_PLACE);
         2351  +
  2344   2352   	Tcl_SetObjResult(interp, resultPtr);
  2345   2353       }
  2346   2354       return TCL_OK;
  2347   2355   }
  2348   2356   
  2349   2357   /*
  2350   2358    *----------------------------------------------------------------------
................................................................................
  3206   3214   	length2 = strlen(tclDefaultTrimSet);
  3207   3215       } else {
  3208   3216   	Tcl_WrongNumArgs(interp, 1, objv, "string ?chars?");
  3209   3217   	return TCL_ERROR;
  3210   3218       }
  3211   3219       string1 = TclGetStringFromObj(objv[1], &length1);
  3212   3220   
  3213         -    triml = TclTrimLeft(string1, length1, string2, length2);
  3214         -    trimr = TclTrimRight(string1 + triml, length1 - triml, string2, length2);
         3221  +    triml = TclTrim(string1, length1, string2, length2, &trimr);
  3215   3222   
  3216   3223       Tcl_SetObjResult(interp,
  3217   3224   	    Tcl_NewStringObj(string1 + triml, length1 - triml - trimr));
  3218   3225       return TCL_OK;
  3219   3226   }
  3220   3227   
  3221   3228   /*

Changes to generic/tclCompCmdsSZ.c.

   991    991       Tcl_Interp *interp,		/* Tcl interpreter for context. */
   992    992       Tcl_Parse *parsePtr,	/* Points to a parse structure for the
   993    993   				 * command. */
   994    994       Command *cmdPtr,		/* Points to defintion of command being
   995    995   				 * compiled. */
   996    996       CompileEnv *envPtr)		/* Holds the resulting instructions. */
   997    997   {
   998         -    Tcl_Token *tokenPtr, *valueTokenPtr, *replacementTokenPtr = NULL;
          998  +    Tcl_Token *tokenPtr, *valueTokenPtr;
   999    999       DefineLineInformation;	/* TIP #280 */
  1000         -    int idx1, idx2;
         1000  +    int first, last;
  1001   1001   
  1002   1002       if (parsePtr->numWords < 4 || parsePtr->numWords > 5) {
  1003   1003   	return TCL_ERROR;
  1004   1004       }
         1005  + 
         1006  +    /* Bytecode to compute/push string argument being replaced */
  1005   1007       valueTokenPtr = TokenAfter(parsePtr->tokenPtr);
  1006         -    if (parsePtr->numWords == 5) {
  1007         -	tokenPtr = TokenAfter(valueTokenPtr);
  1008         -	tokenPtr = TokenAfter(tokenPtr);
  1009         -	replacementTokenPtr = TokenAfter(tokenPtr);
  1010         -    }
         1008  +    CompileWord(envPtr, valueTokenPtr, interp, 1);
  1011   1009   
         1010  +    /*
         1011  +     * Check for first index known and useful at compile time. 
         1012  +     */
  1012   1013       tokenPtr = TokenAfter(valueTokenPtr);
  1013         -    if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_START, TCL_INDEX_AFTER,
  1014         -	    &idx1) != TCL_OK) {
         1014  +    if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_AFTER,
         1015  +	    &first) != TCL_OK) {
  1015   1016   	goto genericReplace;
  1016   1017       }
         1018  +
  1017   1019       /*
  1018         -     * Token parsed as an index value. Indices before the string are
  1019         -     * treated as index of start of string.
         1020  +     * Check for last index known and useful at compile time. 
  1020   1021        */
  1021         -
  1022   1022       tokenPtr = TokenAfter(tokenPtr);
  1023         -    if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_END,
  1024         -	    &idx2) != TCL_OK) {
         1023  +    if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_AFTER,
         1024  +	    &last) != TCL_OK) {
  1025   1025   	goto genericReplace;
  1026   1026       }
  1027         -    /*
  1028         -     * Token parsed as an index value. Indices after the string are
  1029         -     * treated as index of end of string.
  1030         -     */
  1031         -
  1032         -/* TODO...... */
  1033         -    /*
  1034         -     * We handle these replacements specially: first character (where
  1035         -     * idx1=idx2=0) and last character (where idx1=idx2=TCL_INDEX_END). Anything
  1036         -     * else and the semantics get rather screwy.
         1027  +
         1028  +    /* 
         1029  +     * [string replace] is an odd bird.  For many arguments it is
         1030  +     * a conventional substring replacer.  However it also goes out
         1031  +     * of its way to become a no-op for many cases where it would be
         1032  +     * replacing an empty substring.  Precisely, it is a no-op when
         1033  +     *
         1034  +     *		(last < first)		OR
         1035  +     *		(last < 0)		OR
         1036  +     *		(end < first)
         1037  +     *
         1038  +     * For some compile-time values we can detect these cases, and
         1039  +     * compile direct to bytecode implementing the no-op.
         1040  +     */
         1041  +
         1042  +    if ((last == TCL_INDEX_BEFORE)		/* Know (last < 0) */
         1043  +	    || (first == TCL_INDEX_AFTER)	/* Know (first > end) */
         1044  +
         1045  +	/*
         1046  +	 * Tricky to determine when runtime (last < first) can be
         1047  +	 * certainly known based on the encoded values. Consider the
         1048  +	 * cases...
         1049  +	 *
         1050  +	 * (first <= TCL_INDEX_END) &&
         1051  +	 *	(last == TCL_INDEX_AFTER) => cannot tell REJECT
         1052  +	 *	(last <= TCL_INDEX END) && (last < first) => ACCEPT
         1053  +	 *	else => cannot tell REJECT
         1054  +	 */
         1055  +	    || ((first <= TCL_INDEX_END) && (last <= TCL_INDEX_END)
         1056  +		&& (last < first))		/* Know (last < first) */
         1057  +	/*
         1058  +	 * (first == TCL_INDEX_BEFORE) &&
         1059  +	 *	(last == TCL_INDEX_AFTER) => (first < last) REJECT
         1060  +	 *	(last <= TCL_INDEX_END) => cannot tell REJECT
         1061  +	 *	else		=> (first < last) REJECT
         1062  +	 *
         1063  +	 * else [[first >= TCL_INDEX_START]] &&
         1064  +	 *	(last == TCL_INDEX_AFTER) => cannot tell REJECT
         1065  +	 *	(last <= TCL_INDEX_END) => cannot tell REJECT
         1066  +	 *	else [[last >= TCL_INDEX START]] && (last < first) => ACCEPT
         1067  +	 */
         1068  +	    || ((first >= TCL_INDEX_START) && (last >= TCL_INDEX_START)
         1069  +		&& (last < first))) {		/* Know (last < first) */
         1070  +	if (parsePtr->numWords == 5) {
         1071  +	    tokenPtr = TokenAfter(tokenPtr);
         1072  +	    CompileWord(envPtr, tokenPtr, interp, 4);
         1073  +	    OP(		POP);		/* Pop newString */
         1074  +	}
         1075  +	/* Original string argument now on TOS as result */
         1076  +	return TCL_OK;
         1077  +    }
         1078  +
         1079  +    if (parsePtr->numWords == 5) {
         1080  +    /*
         1081  +     * When we have a string replacement, we have to take care about
         1082  +     * not replacing empty substrings that [string replace] promises
         1083  +     * not to replace
         1084  +     *
         1085  +     * The remaining index values might be suitable for conventional
         1086  +     * string replacement, but only if they cannot possibly meet the
         1087  +     * conditions described above at runtime. If there's a chance they
         1088  +     * might, we would have to emit bytecode to check and at that point
         1089  +     * we're paying more in bytecode execution time than would make
         1090  +     * things worthwhile. Trouble is we are very limited in
         1091  +     * how much we can detect that at compile time. After decoding,
         1092  +     * we need, first:
         1093  +     *
         1094  +     *		(first <= end)
         1095  +     *
         1096  +     * The encoded indices (first <= TCL_INDEX END) and
         1097  +     * (first == TCL_INDEX_BEFORE) always meets this condition, but
         1098  +     * any other encoded first index has some list for which it fails.
         1099  +     *
         1100  +     * We also need, second:
         1101  +     *
         1102  +     *		(last >= 0)
         1103  +     *
         1104  +     * The encoded indices (last >= TCL_INDEX_START) and
         1105  +     * (last == TCL_INDEX_AFTER) always meet this condition but any
         1106  +     * other encoded last index has some list for which it fails.
  1037   1107        *
  1038         -     * TODO: These seem to be very narrow cases.  They are not even
  1039         -     * covered by the test suite, and any programming that ends up
  1040         -     * here could have been coded by the programmer using [string range]
  1041         -     * and [string cat]. [*]  Not clear at all to me that the bytecode
  1042         -     * generated here is worthwhile.
         1108  +     * Finally we need, third:
  1043   1109        *
  1044         -     *  [*] Except for the empty string exceptions.  UGGGGHHHH.
  1045         -     */
  1046         -
  1047         -    if (idx1 == 0 && idx2 == 0) {
  1048         -	int notEq, end;
  1049         -
  1050         -	/*
  1051         -	 * Just working with the first character.
  1052         -	 */
  1053         -
  1054         -	CompileWord(envPtr, valueTokenPtr, interp, 1);
  1055         -	if (replacementTokenPtr == NULL) {
  1056         -	    /* Drop first */
  1057         -	    OP44(	STR_RANGE_IMM, 1, TCL_INDEX_END);
  1058         -	    return TCL_OK;
  1059         -	}
  1060         -	/* Replace first */
  1061         -	CompileWord(envPtr, replacementTokenPtr, interp, 4);
  1062         -
  1063         -	/*
  1064         -	 * NOTE: The following tower of bullshit is present because
  1065         -	 * [string replace] was boneheadedly defined not to replace
  1066         -	 * empty strings, so we actually have to detect the empty
  1067         -	 * string case and treat it differently.
  1068         -	 */
  1069         -
  1070         -	OP4(		OVER, 1);
  1071         -	PUSH(		"");
  1072         -	OP(		STR_EQ);
  1073         -	JUMP1(		JUMP_FALSE, notEq);
  1074         -	OP(		POP);
  1075         -	JUMP1(		JUMP, end);
  1076         -	FIXJUMP1(notEq);
  1077         -	TclAdjustStackDepth(1, envPtr);
         1110  +     *		(first <= last)
         1111  +     * 
         1112  +     * Considered in combination with the constraints we already have,
         1113  +     * we see that we can proceed when (first == TCL_INDEX_BEFORE)
         1114  +     * or (last == TCL_INDEX_AFTER). These also permit simplification
         1115  +     * of the prefix|replace|suffix construction. The other constraints,
         1116  +     * though, interfere with getting a guarantee that first <= last. 
         1117  +     */
         1118  +
         1119  +    if ((first == TCL_INDEX_BEFORE) && (last >= TCL_INDEX_START)) {
         1120  +	/* empty prefix */
         1121  +	tokenPtr = TokenAfter(tokenPtr);
         1122  +	CompileWord(envPtr, tokenPtr, interp, 4);
  1078   1123   	OP4(		REVERSE, 2);
  1079         -	OP44(		STR_RANGE_IMM, 1, TCL_INDEX_END);
         1124  +	if (last == TCL_INDEX_AFTER) {
         1125  +	    OP(		POP);		/* Pop  original */
         1126  +	} else {
         1127  +	    OP44(	STR_RANGE_IMM, last + 1, TCL_INDEX_END);
         1128  +	    OP1(	STR_CONCAT1, 2);
         1129  +	}
         1130  +	return TCL_OK;
         1131  +    }
         1132  +
         1133  +    if ((last == TCL_INDEX_AFTER) && (first <= TCL_INDEX_END)) {
         1134  +	OP44(		STR_RANGE_IMM, 0, first-1);
         1135  +	tokenPtr = TokenAfter(tokenPtr);
         1136  +	CompileWord(envPtr, tokenPtr, interp, 4);
  1080   1137   	OP1(		STR_CONCAT1, 2);
  1081         -	FIXJUMP1(end);
  1082   1138   	return TCL_OK;
         1139  +    }
  1083   1140   
  1084         -    } else if (idx1 == TCL_INDEX_END && idx2 == TCL_INDEX_END) {
  1085         -	int notEq, end;
         1141  +	/* FLOW THROUGH TO genericReplace */
  1086   1142   
  1087         -	/*
  1088         -	 * Just working with the last character.
         1143  +    } else {
         1144  +	/* 
         1145  +	 * When we have no replacement string to worry about, we may
         1146  +	 * have more luck, because the forbidden empty string replacements
         1147  +	 * are harmless when they are replaced by another empty string.
  1089   1148   	 */
  1090   1149   
  1091         -	CompileWord(envPtr, valueTokenPtr, interp, 1);
  1092         -	if (replacementTokenPtr == NULL) {
  1093         -	    /* Drop last */
  1094         -	    OP44(	STR_RANGE_IMM, 0, TCL_INDEX_END-1);
         1150  +	if ((first == TCL_INDEX_BEFORE) || (first == TCL_INDEX_START)) {
         1151  +	    /* empty prefix - build suffix only */
         1152  +
         1153  +	    if ((last == TCL_INDEX_END) || (last == TCL_INDEX_AFTER)) {
         1154  +		/* empty suffix too => empty result */
         1155  +		OP(	POP);		/* Pop  original */
         1156  +		PUSH	(	"");
         1157  +		return TCL_OK;
         1158  +	    }
         1159  +	    OP44(	STR_RANGE_IMM, last + 1, TCL_INDEX_END);
         1160  +	    return TCL_OK;
         1161  +	} else {
         1162  +	    if ((last == TCL_INDEX_END) || (last == TCL_INDEX_AFTER)) {
         1163  +		/* empty suffix - build prefix only */
         1164  +		OP44(	STR_RANGE_IMM, 0, first-1);
         1165  +		return TCL_OK;
         1166  +	    }
         1167  +	    OP(		DUP);
         1168  +	    OP44(	STR_RANGE_IMM, 0, first-1);
         1169  +	    OP4(	REVERSE, 2);
         1170  +	    OP44(	STR_RANGE_IMM, last + 1, TCL_INDEX_END);
         1171  +	    OP1(	STR_CONCAT1, 2);
  1095   1172   	    return TCL_OK;
  1096   1173   	}
  1097         -	/* Replace last */
  1098         -	CompileWord(envPtr, replacementTokenPtr, interp, 4);
  1099         -
  1100         -	/* More bullshit; see NOTE above. */
  1101         -
  1102         -	OP4(		OVER, 1);
  1103         -	PUSH(		"");
  1104         -	OP(		STR_EQ);
  1105         -	JUMP1(		JUMP_FALSE, notEq);
  1106         -	OP(		POP);
  1107         -	JUMP1(		JUMP, end);
  1108         -	FIXJUMP1(notEq);
  1109         -	TclAdjustStackDepth(1, envPtr);
  1110         -	OP4(		REVERSE, 2);
  1111         -	OP44(		STR_RANGE_IMM, 0, TCL_INDEX_END-1);
  1112         -	OP4(		REVERSE, 2);
  1113         -	OP1(		STR_CONCAT1, 2);
  1114         -	FIXJUMP1(end);
  1115         -	return TCL_OK;
  1116         -
  1117         -    } else {
  1118         -	/*
  1119         -	 * Need to process indices at runtime. This could be because the
  1120         -	 * indices are not constants, or because we need to resolve them to
  1121         -	 * absolute indices to work out if a replacement is going to happen.
  1122         -	 * In any case, to runtime it is.
  1123         -	 */
         1174  +    }
  1124   1175   
  1125   1176       genericReplace:
  1126         -	CompileWord(envPtr, valueTokenPtr, interp, 1);
  1127   1177   	tokenPtr = TokenAfter(valueTokenPtr);
  1128   1178   	CompileWord(envPtr, tokenPtr, interp, 2);
  1129   1179   	tokenPtr = TokenAfter(tokenPtr);
  1130   1180   	CompileWord(envPtr, tokenPtr, interp, 3);
  1131         -	if (replacementTokenPtr != NULL) {
  1132         -	    CompileWord(envPtr, replacementTokenPtr, interp, 4);
         1181  +	if (parsePtr->numWords == 5) {
         1182  +	    tokenPtr = TokenAfter(tokenPtr);
         1183  +	    CompileWord(envPtr, tokenPtr, interp, 4);
  1133   1184   	} else {
  1134   1185   	    PUSH(	"");
  1135   1186   	}
  1136   1187   	OP(		STR_REPLACE);
  1137   1188   	return TCL_OK;
  1138         -    }
  1139   1189   }
  1140   1190   
  1141   1191   int
  1142   1192   TclCompileStringTrimLCmd(
  1143   1193       Tcl_Interp *interp,		/* Used for error reporting. */
  1144   1194       Tcl_Parse *parsePtr,	/* Points to a parse structure for the command
  1145   1195   				 * created by Tcl_ParseCommand. */

Changes to generic/tclExecute.c.

  5418   5418   	    TclNewObj(objResultPtr);
  5419   5419   	}
  5420   5420   	TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
  5421   5421   	NEXT_INST_F(9, 1, 1);
  5422   5422   
  5423   5423       {
  5424   5424   	Tcl_UniChar *ustring1, *ustring2, *ustring3, *end, *p;
  5425         -	int length3;
         5425  +	int length3, endIdx;
  5426   5426   	Tcl_Obj *value3Ptr;
  5427   5427   
  5428   5428       case INST_STR_REPLACE:
  5429   5429   	value3Ptr = POP_OBJECT();
  5430   5430   	valuePtr = OBJ_AT_DEPTH(2);
  5431         -	length = Tcl_GetCharLength(valuePtr) - 1;
         5431  +	endIdx = Tcl_GetCharLength(valuePtr) - 1;
  5432   5432   	TRACE(("\"%.20s\" %s %s \"%.20s\" => ", O2S(valuePtr),
  5433   5433   		O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), O2S(value3Ptr)));
  5434         -	if (TclGetIntForIndexM(interp, OBJ_UNDER_TOS, length,
         5434  +	if (TclGetIntForIndexM(interp, OBJ_UNDER_TOS, endIdx,
  5435   5435   		    &fromIdx) != TCL_OK
  5436         -	    || TclGetIntForIndexM(interp, OBJ_AT_TOS, length,
         5436  +	    || TclGetIntForIndexM(interp, OBJ_AT_TOS, endIdx,
  5437   5437   		    &toIdx) != TCL_OK) {
  5438   5438   	    TclDecrRefCount(value3Ptr);
  5439   5439   	    TRACE_ERROR(interp);
  5440   5440   	    goto gotError;
  5441   5441   	}
  5442   5442   	TclDecrRefCount(OBJ_AT_TOS);
  5443   5443   	(void) POP_OBJECT();
  5444   5444   	TclDecrRefCount(OBJ_AT_TOS);
  5445   5445   	(void) POP_OBJECT();
  5446         -	if (fromIdx < 0) {
  5447         -	    fromIdx = 0;
  5448         -	}
  5449   5446   
  5450         -	if (fromIdx > toIdx || fromIdx > length) {
         5447  +	if ((toIdx < 0) ||
         5448  +		(fromIdx > endIdx) ||
         5449  +		(toIdx < fromIdx)) {
  5451   5450   	    TRACE_APPEND(("\"%.30s\"\n", O2S(valuePtr)));
  5452   5451   	    TclDecrRefCount(value3Ptr);
  5453   5452   	    NEXT_INST_F(1, 0, 0);
  5454   5453   	}
  5455   5454   
  5456         -	if (toIdx > length) {
  5457         -	    toIdx = length;
         5455  +	if (fromIdx < 0) {
         5456  +	    fromIdx = 0;
  5458   5457   	}
  5459   5458   
  5460         -	if (fromIdx == 0 && toIdx == length) {
         5459  +	if (toIdx > endIdx) {
         5460  +	    toIdx = endIdx;
         5461  +	}
         5462  +
         5463  +	if (fromIdx == 0 && toIdx == endIdx) {
  5461   5464   	    TclDecrRefCount(OBJ_AT_TOS);
  5462   5465   	    OBJ_AT_TOS = value3Ptr;
  5463   5466   	    TRACE_APPEND(("\"%.30s\"\n", O2S(value3Ptr)));
  5464   5467   	    NEXT_INST_F(1, 0, 0);
  5465   5468   	}
  5466   5469   
  5467         -	length3 = Tcl_GetCharLength(value3Ptr);
         5470  +	objResultPtr = TclStringReplace(interp, valuePtr, fromIdx,
         5471  +		toIdx - fromIdx + 1, value3Ptr, TCL_STRING_IN_PLACE);
  5468   5472   
  5469         -	/*
  5470         -	 * See if we can splice in place. This happens when the number of
  5471         -	 * characters being replaced is the same as the number of characters
  5472         -	 * in the string to be inserted.
  5473         -	 */
  5474         -
  5475         -	if (length3 - 1 == toIdx - fromIdx) {
  5476         -	    unsigned char *bytes1, *bytes2;
  5477         -
  5478         -	    if (Tcl_IsShared(valuePtr)) {
  5479         -		objResultPtr = Tcl_DuplicateObj(valuePtr);
  5480         -	    } else {
  5481         -		objResultPtr = valuePtr;
  5482         -	    }
  5483         -	    if (TclIsPureByteArray(objResultPtr)
  5484         -		    && TclIsPureByteArray(value3Ptr)) {
  5485         -		bytes1 = Tcl_GetByteArrayFromObj(objResultPtr, NULL);
  5486         -		bytes2 = Tcl_GetByteArrayFromObj(value3Ptr, NULL);
  5487         -		memcpy(bytes1 + fromIdx, bytes2, length3);
  5488         -	    } else {
  5489         -		ustring1 = Tcl_GetUnicodeFromObj(objResultPtr, NULL);
  5490         -		ustring2 = Tcl_GetUnicodeFromObj(value3Ptr, NULL);
  5491         -		memcpy(ustring1 + fromIdx, ustring2,
  5492         -			length3 * sizeof(Tcl_UniChar));
  5493         -	    }
  5494         -	    Tcl_InvalidateStringRep(objResultPtr);
  5495         -	    TclDecrRefCount(value3Ptr);
  5496         -	    TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr)));
  5497         -	    if (objResultPtr == valuePtr) {
  5498         -		NEXT_INST_F(1, 0, 0);
  5499         -	    } else {
  5500         -		NEXT_INST_F(1, 1, 1);
  5501         -	    }
  5502         -	}
  5503         -
  5504         -	/*
  5505         -	 * Get the unicode representation; this is where we guarantee to lose
  5506         -	 * bytearrays.
  5507         -	 */
  5508         -
  5509         -	ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length);
  5510         -	length--;
  5511         -
  5512         -	/*
  5513         -	 * Remove substring using copying.
  5514         -	 */
  5515         -
  5516         -	objResultPtr = NULL;
  5517         -	if (fromIdx > 0) {
  5518         -	    objResultPtr = Tcl_NewUnicodeObj(ustring1, fromIdx);
  5519         -	}
  5520         -	if (length3 > 0) {
  5521         -	    if (objResultPtr) {
  5522         -		Tcl_AppendObjToObj(objResultPtr, value3Ptr);
  5523         -	    } else if (Tcl_IsShared(value3Ptr)) {
  5524         -		objResultPtr = Tcl_DuplicateObj(value3Ptr);
  5525         -	    } else {
  5526         -		objResultPtr = value3Ptr;
  5527         -	    }
  5528         -	}
  5529         -	if (toIdx < length) {
  5530         -	    if (objResultPtr) {
  5531         -		Tcl_AppendUnicodeToObj(objResultPtr, ustring1 + toIdx + 1,
  5532         -			length - toIdx);
  5533         -	    } else {
  5534         -		objResultPtr = Tcl_NewUnicodeObj(ustring1 + toIdx + 1,
  5535         -			length - toIdx);
  5536         -	    }
  5537         -	}
  5538         -	if (objResultPtr == NULL) {
  5539         -	    /* This has to be the case [string replace $s 0 end {}] */
  5540         -	    /* which has result {} which is same as value3Ptr. */
  5541         -	    objResultPtr = value3Ptr;
  5542         -	}
  5543   5473   	if (objResultPtr == value3Ptr) {
  5544   5474   	    /* See [Bug 82e7f67325] */
  5545   5475   	    TclDecrRefCount(OBJ_AT_TOS);
  5546   5476   	    OBJ_AT_TOS = value3Ptr;
  5547   5477   	    TRACE_APPEND(("\"%.30s\"\n", O2S(value3Ptr)));
  5548   5478   	    NEXT_INST_F(1, 0, 0);
  5549   5479   	}
................................................................................
  5710   5640   	trim1 = 0;
  5711   5641   	goto createTrimmedString;
  5712   5642       case INST_STR_TRIM:
  5713   5643   	valuePtr = OBJ_UNDER_TOS;	/* String */
  5714   5644   	value2Ptr = OBJ_AT_TOS;		/* TrimSet */
  5715   5645   	string2 = TclGetStringFromObj(value2Ptr, &length2);
  5716   5646   	string1 = TclGetStringFromObj(valuePtr, &length);
  5717         -	trim1 = TclTrimLeft(string1, length, string2, length2);
  5718         -	if (trim1 < length) {
  5719         -	    trim2 = TclTrimRight(string1, length, string2, length2);
  5720         -	} else {
  5721         -	    trim2 = 0;
  5722         -	}
         5647  +	trim1 = TclTrim(string1, length, string2, length2, &trim2);
  5723   5648       createTrimmedString:
  5724   5649   	/*
  5725   5650   	 * Careful here; trim set often contains non-ASCII characters so we
  5726   5651   	 * take care when printing. [Bug 971cb4f1db]
  5727   5652   	 */
  5728   5653   
  5729   5654   #ifdef TCL_COMPILE_DEBUG

Changes to generic/tclInt.h.

  3194   3194   			    Tcl_Obj *const opts[], int *flagPtr);
  3195   3195   MODULE_SCOPE void	TclSubstParse(Tcl_Interp *interp, const char *bytes,
  3196   3196   			    int numBytes, int flags, Tcl_Parse *parsePtr,
  3197   3197   			    Tcl_InterpState *statePtr);
  3198   3198   MODULE_SCOPE int	TclSubstTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr,
  3199   3199   			    int count, int *tokensLeftPtr, int line,
  3200   3200   			    int *clNextOuter, const char *outerScript);
         3201  +MODULE_SCOPE int	TclTrim(const char *bytes, int numBytes,
         3202  +			    const char *trim, int numTrim, int *trimRight);
  3201   3203   MODULE_SCOPE int	TclTrimLeft(const char *bytes, int numBytes,
  3202   3204   			    const char *trim, int numTrim);
  3203   3205   MODULE_SCOPE int	TclTrimRight(const char *bytes, int numBytes,
  3204   3206   			    const char *trim, int numTrim);
  3205   3207   MODULE_SCOPE int	TclUtfCmp(const char *cs, const char *ct);
  3206   3208   MODULE_SCOPE int	TclUtfCasecmp(const char *cs, const char *ct);
  3207   3209   MODULE_SCOPE int	TclUtfCount(int ch);
................................................................................
  4000   4002   			    Tcl_Obj *const objv[], int flags);
  4001   4003   MODULE_SCOPE int	TclStringFirst(Tcl_Obj *needle, Tcl_Obj *haystack,
  4002   4004   			    int start);
  4003   4005   MODULE_SCOPE int	TclStringLast(Tcl_Obj *needle, Tcl_Obj *haystack,
  4004   4006   			    int last);
  4005   4007   MODULE_SCOPE Tcl_Obj *	TclStringRepeat(Tcl_Interp *interp, Tcl_Obj *objPtr,
  4006   4008   			    int count, int flags);
         4009  +MODULE_SCOPE Tcl_Obj *	TclStringReplace(Tcl_Interp *interp, Tcl_Obj *objPtr,
         4010  +			    int first, int count, Tcl_Obj *insertPtr,
         4011  +			    int flags);
  4007   4012   MODULE_SCOPE Tcl_Obj *	TclStringReverse(Tcl_Obj *objPtr, int flags);
  4008   4013   
  4009   4014   /* Flag values for the [string] ensemble functions. */
  4010   4015   
  4011   4016   #define TCL_STRING_MATCH_NOCASE TCL_MATCH_NOCASE /* (1<<0) in tcl.h */
  4012   4017   #define TCL_STRING_IN_PLACE (1<<1)
  4013   4018   
................................................................................
  4062   4067   
  4063   4068   MODULE_SCOPE int	TclCompareObjKeys(void *keyPtr, Tcl_HashEntry *hPtr);
  4064   4069   MODULE_SCOPE void	TclFreeObjEntry(Tcl_HashEntry *hPtr);
  4065   4070   MODULE_SCOPE TCL_HASH_TYPE TclHashObjKey(Tcl_HashTable *tablePtr, void *keyPtr);
  4066   4071   
  4067   4072   MODULE_SCOPE int	TclFullFinalizationRequested(void);
  4068   4073   
         4074  +/*
         4075  + * TIP #462.
         4076  + */
         4077  +
         4078  +/*
         4079  + * The following enum values give the status of a spawned process.
         4080  + */
         4081  +
         4082  +typedef enum TclProcessWaitStatus {
         4083  +    TCL_PROCESS_ERROR = -1,	/* Error waiting for process to exit */
         4084  +    TCL_PROCESS_UNCHANGED = 0,	/* No change since the last call. */
         4085  +    TCL_PROCESS_EXITED = 1,	/* Process has exited. */
         4086  +    TCL_PROCESS_SIGNALED = 2,	/* Child killed because of a signal. */
         4087  +    TCL_PROCESS_STOPPED = 3,	/* Child suspended because of a signal. */
         4088  +    TCL_PROCESS_UNKNOWN_STATUS = 4 
         4089  +				/* Child wait status didn't make sense. */
         4090  +} TclProcessWaitStatus;
         4091  +
         4092  +MODULE_SCOPE Tcl_Command TclInitProcessCmd(Tcl_Interp *interp);
         4093  +MODULE_SCOPE void	TclProcessCreated(Tcl_Pid pid);
         4094  +MODULE_SCOPE TclProcessWaitStatus TclProcessWait(Tcl_Pid pid, int options,
         4095  +			    int *codePtr, Tcl_Obj **msgObjPtr,
         4096  +			    Tcl_Obj **errorObjPtr);
         4097  +
  4069   4098   /*
  4070   4099    * Utility routines for encoding index values as integers. Used by both
  4071   4100    * some of the command compilers and by [lsort] and [lsearch].
  4072   4101    */
  4073   4102   
  4074   4103   MODULE_SCOPE int	TclIndexEncode(Tcl_Interp *interp, Tcl_Obj *objPtr,
  4075   4104   			    int before, int after, int *indexPtr);

Changes to generic/tclOO.c.

   507    507   InitClassSystemRoots(
   508    508       Tcl_Interp *interp,
   509    509       Foundation *fPtr)
   510    510   {
   511    511       Class fakeCls;
   512    512       Object fakeObject;
   513    513   
   514         -    /*
   515         -     * Stand up a phony class for bootstrapping.
   516         -     */
   517         -
          514  +    /* Stand up a phony class for bootstrapping. */
   518    515       fPtr->objectCls = &fakeCls;
   519         -
   520         -    /*
   521         -     * Referenced in AllocClass to increment the refCount.
   522         -     */
   523         -
          516  +    /* referenced in AllocClass to increment the refCount. */
   524    517       fakeCls.thisPtr = &fakeObject;
   525    518   
   526    519       fPtr->objectCls = AllocClass(interp,
   527    520   	    AllocObject(interp, "object", (Namespace *)fPtr->ooNs, NULL));
   528         -    fPtr->classCls = AllocClass(interp,
   529         -	    AllocObject(interp, "class", (Namespace *)fPtr->ooNs, NULL));
   530         -
   531         -    /*
   532         -     * Rewire bootstrapped objects.
   533         -     */
   534         -
   535         -    fPtr->objectCls->thisPtr->selfCls = fPtr->classCls;
   536         -    fPtr->classCls->thisPtr->selfCls = fPtr->classCls;
   537         -
          521  +    /* Corresponding TclOODecrRefCount in KillFoudation */
   538    522       AddRef(fPtr->objectCls->thisPtr);
   539         -    AddRef(fPtr->classCls->thisPtr);
   540         -    AddRef(fPtr->classCls->thisPtr->selfCls->thisPtr);
   541         -    AddRef(fPtr->objectCls->thisPtr->selfCls->thisPtr);
   542    523   
   543         -    /*
   544         -     * Special initialization for the primordial objects.
   545         -     */
          524  +    /* This is why it is unnecessary in this routine to replace the
          525  +     * incremented reference count of fPtr->objectCls that was swallowed by
          526  +     * fakeObject. */
          527  +    fPtr->objectCls->superclasses.num = 0;
          528  +    ckfree(fPtr->objectCls->superclasses.list);
          529  +    fPtr->objectCls->superclasses.list = NULL;
   546    530   
          531  +    /* special initialization for the primordial objects */
   547    532       fPtr->objectCls->thisPtr->flags |= ROOT_OBJECT;
   548    533       fPtr->objectCls->flags |= ROOT_OBJECT;
   549    534   
          535  +    fPtr->classCls = AllocClass(interp,
          536  +	    AllocObject(interp, "class", (Namespace *)fPtr->ooNs, NULL));
          537  +    /* Corresponding TclOODecrRefCount in KillFoudation */
          538  +    AddRef(fPtr->classCls->thisPtr);
          539  +
   550    540       /*
   551         -     * This is why it is unnecessary in this routine to make up for the
   552         -     * incremented reference count of fPtr->objectCls that was sallwed by
   553         -     * fakeObject.
          541  +     * Increment reference counts for each reference because these
          542  +     * relationships can be dynamically changed.
          543  +     *
          544  +     * Corresponding TclOODecrRefCount for all incremented refcounts is in
          545  +     * KillFoundation.
   554    546        */
   555    547   
   556         -    fPtr->objectCls->superclasses.num = 0;
   557         -    ckfree(fPtr->objectCls->superclasses.list);
   558         -    fPtr->objectCls->superclasses.list = NULL;
          548  +    /* Rewire bootstrapped objects. */
          549  +    fPtr->objectCls->thisPtr->selfCls = fPtr->classCls;
          550  +    AddRef(fPtr->classCls->thisPtr);
          551  +    TclOOAddToInstances(fPtr->objectCls->thisPtr, fPtr->classCls);
          552  +
          553  +    fPtr->classCls->thisPtr->selfCls = fPtr->classCls;
          554  +    AddRef(fPtr->classCls->thisPtr);
          555  +    TclOOAddToInstances(fPtr->classCls->thisPtr, fPtr->classCls);
   559    556   
   560    557       fPtr->classCls->thisPtr->flags |= ROOT_CLASS;
   561    558       fPtr->classCls->flags |= ROOT_CLASS;
   562    559   
   563         -    /*
   564         -     * Standard initialization for new Objects.
   565         -     */
   566         -
   567         -    TclOOAddToInstances(fPtr->objectCls->thisPtr, fPtr->classCls);
   568         -    TclOOAddToInstances(fPtr->classCls->thisPtr, fPtr->classCls);
          560  +    /* Standard initialization for new Objects */
   569    561       TclOOAddToSubclasses(fPtr->classCls, fPtr->objectCls);
   570    562   
   571    563       /*
   572    564        * THIS IS THE ONLY FUNCTION THAT DOES NON-STANDARD CLASS SPLICING.
   573    565        * Everything else is careful to prohibit looping.
   574    566        */
   575    567   }
................................................................................
   628    620       ClientData clientData,	/* Pointer to the OO system foundation
   629    621   				 * structure. */
   630    622       Tcl_Interp *interp)		/* The interpreter containing the OO system
   631    623   				 * foundation. */
   632    624   {
   633    625       Foundation *fPtr = GetFoundation(interp);
   634    626   
   635         -    /*
   636         -     * Crude mechanism to avoid leaking the Object struct of the
   637         -     * foundation components oo::object and oo::class
   638         -     *
   639         -     * Should probably be replaced with something more elegantly designed.
   640         -     */
   641         -    while (TclOODecrRefCount(fPtr->objectCls->thisPtr) == 0) {};
   642         -    while (TclOODecrRefCount(fPtr->classCls->thisPtr) == 0) {};
   643         -
   644    627       TclDecrRefCount(fPtr->unknownMethodNameObj);
   645    628       TclDecrRefCount(fPtr->constructorName);
   646    629       TclDecrRefCount(fPtr->destructorName);
   647    630       TclDecrRefCount(fPtr->clonedName);
   648    631       TclDecrRefCount(fPtr->defineName);
          632  +    TclOODecrRefCount(fPtr->objectCls->thisPtr);
          633  +    TclOODecrRefCount(fPtr->classCls->thisPtr);
          634  +
   649    635       ckfree(fPtr);
   650    636   }
   651    637   
   652    638   /*
   653    639    * ----------------------------------------------------------------------
   654    640    *
   655    641    * AllocObject --
................................................................................
   725    711   	 * have to get rid of the error message from Tcl_CreateNamespace,
   726    712   	 * since that's something that should not be exposed to the user.
   727    713   	 */
   728    714   
   729    715   	Tcl_ResetResult(interp);
   730    716       }
   731    717   
          718  +
          719  +  configNamespace:
          720  +
          721  +    ((Namespace *)oPtr->namespacePtr)->refCount++;
          722  +
   732    723       /*
   733    724        * Make the namespace know about the helper commands. This grants access
   734    725        * to the [self] and [next] commands.
   735    726        */
   736    727   
   737         -  configNamespace:
   738    728       if (fPtr->helpersNs != NULL) {
   739    729   	TclSetNsPath((Namespace *) oPtr->namespacePtr, 1, &fPtr->helpersNs);
   740    730       }
   741    731       TclOOSetupVariableResolver(oPtr->namespacePtr);
   742    732   
   743    733       /*
   744    734        * Suppress use of compiled versions of the commands in this object's
................................................................................
   897    887       TclOODecrRefCount(oPtr);
   898    888       return;
   899    889   }
   900    890   
   901    891   /*
   902    892    * ----------------------------------------------------------------------
   903    893    *
   904         - * DeleteDescendants, ReleaseClassContents --
          894  + * DeleteDescendants --
   905    895    *
   906         - *	Tear down the special class data structure, including deleting all
   907         - *	dependent classes and objects.
          896  + *	Delete all descendants of a particular class.
   908    897    *
   909    898    * ----------------------------------------------------------------------
   910    899    */
   911    900   
   912    901   static void
   913    902   DeleteDescendants(
   914    903       Tcl_Interp *interp,		/* The interpreter containing the class. */
   915    904       Object *oPtr)		/* The object representing the class. */
   916    905   {
   917    906       Class *clsPtr = oPtr->classPtr, *subclassPtr, *mixinSubclassPtr;
   918    907       Object *instancePtr;
   919         -    int i;
   920    908   
   921    909       /*
   922    910        * Squelch classes that this class has been mixed into.
   923    911        */
   924    912   
   925         -    FOREACH(mixinSubclassPtr, clsPtr->mixinSubs) {
   926         -	/*
   927         -	 * This condition also covers the case where mixinSubclassPtr ==
   928         -	 * clsPtr
   929         -	 */
   930         -
   931         -	if (!Deleted(mixinSubclassPtr->thisPtr)) {
   932         -	    Tcl_DeleteCommandFromToken(interp,
   933         -		    mixinSubclassPtr->thisPtr->command);
          913  +    if (clsPtr->mixinSubs.num > 0) {
          914  +	while (clsPtr->mixinSubs.num > 0) {
          915  +	    mixinSubclassPtr = clsPtr->mixinSubs.list[clsPtr->mixinSubs.num-1];
          916  +	    /* This condition also covers the case where mixinSubclassPtr ==
          917  +	     * clsPtr
          918  +	     */
          919  +	    if (!Deleted(mixinSubclassPtr->thisPtr)) {
          920  +		Tcl_DeleteCommandFromToken(interp,
          921  +			mixinSubclassPtr->thisPtr->command);
          922  +	    }
          923  +	    TclOORemoveFromMixinSubs(mixinSubclassPtr, clsPtr);
   934    924   	}
   935         -	i -= TclOORemoveFromMixinSubs(mixinSubclassPtr, clsPtr);
   936         -	TclOODecrRefCount(mixinSubclassPtr->thisPtr);
          925  +    }
          926  +    if (clsPtr->mixinSubs.size > 0) {
          927  +	ckfree(clsPtr->mixinSubs.list);
          928  +	clsPtr->mixinSubs.size = 0;
   937    929       }
   938    930   
   939    931       /*
   940    932        * Squelch subclasses of this class.
   941    933        */
   942    934   
   943         -    FOREACH(subclassPtr, clsPtr->subclasses) {
   944         -	if (!Deleted(subclassPtr->thisPtr) && !IsRoot(subclassPtr)) {
   945         -	    Tcl_DeleteCommandFromToken(interp, subclassPtr->thisPtr->command);
          935  +    if (clsPtr->subclasses.num > 0) {
          936  +	while (clsPtr->subclasses.num > 0) {
          937  +	    subclassPtr = clsPtr->subclasses.list[clsPtr->subclasses.num-1];
          938  +	    if (!Deleted(subclassPtr->thisPtr) && !IsRoot(subclassPtr)) {
          939  +		Tcl_DeleteCommandFromToken(interp, subclassPtr->thisPtr->command);
          940  +	    }
          941  +	    TclOORemoveFromSubclasses(subclassPtr, clsPtr);
   946    942   	}
   947         -	i -= TclOORemoveFromSubclasses(subclassPtr, clsPtr);
   948         -	TclOODecrRefCount(subclassPtr->thisPtr);
          943  +    }
          944  +    if (clsPtr->subclasses.size > 0) {
          945  +	ckfree(clsPtr->subclasses.list);
          946  +	clsPtr->subclasses.list = NULL;
          947  +	clsPtr->subclasses.size = 0;
   949    948       }
   950    949   
   951    950       /*
   952    951        * Squelch instances of this class (includes objects we're mixed into).
   953    952        */
   954    953   
   955         -    if (!IsRootClass(oPtr)) {
   956         -	FOREACH(instancePtr, clsPtr->instances) {
          954  +    if (clsPtr->instances.num > 0) {
          955  +	while (clsPtr->instances.num > 0) {
          956  +	    instancePtr = clsPtr->instances.list[clsPtr->instances.num-1];
   957    957   	    /*
   958    958   	     * This condition also covers the case where instancePtr == oPtr
   959    959   	     */
   960    960   
   961    961   	    if (!Deleted(instancePtr) && !IsRoot(instancePtr)) {
   962    962   		Tcl_DeleteCommandFromToken(interp, instancePtr->command);
   963    963   	    }
   964         -	    i -= TclOORemoveFromInstances(instancePtr, clsPtr);
          964  +	    TclOORemoveFromInstances(instancePtr, clsPtr);
   965    965   	}
   966    966       }
          967  +    if (clsPtr->instances.size > 0) {
          968  +	ckfree(clsPtr->instances.list);
          969  +	clsPtr->instances.list = NULL;
          970  +	clsPtr->instances.size = 0;
          971  +    }
   967    972   }
          973  +
          974  +/*
          975  + * ----------------------------------------------------------------------
          976  + *
          977  + * ReleaseClassContents --
          978  + *
          979  + *	Tear down the special class data structure, including deleting all
          980  + *	dependent classes and objects.
          981  + *
          982  + * ----------------------------------------------------------------------
          983  + */
   968    984   
   969    985   static void
   970    986   ReleaseClassContents(
   971    987       Tcl_Interp *interp,		/* The interpreter containing the class. */
   972    988       Object *oPtr)		/* The object representing the class. */
   973    989   {
   974    990       FOREACH_HASH_DECLS;
................................................................................
  1029   1045   	    TclDecrRefCount(filterObj);
  1030   1046   	}
  1031   1047   	ckfree(clsPtr->filters.list);
  1032   1048   	clsPtr->filters.list = NULL;
  1033   1049   	clsPtr->filters.num = 0;
  1034   1050       }
  1035   1051   
  1036         -    /*
  1037         -     * Squelch our instances.
  1038         -     */
  1039         -
  1040         -    if (clsPtr->instances.num) {
  1041         -	Object *oPtr;
  1042         -
  1043         -	FOREACH(oPtr, clsPtr->instances) {
  1044         -	    TclOODecrRefCount(oPtr);
  1045         -	}
  1046         -	ckfree(clsPtr->instances.list);
  1047         -	clsPtr->instances.list = NULL;
  1048         -	clsPtr->instances.num = 0;
  1049         -    }
  1050         -
  1051   1052       /*
  1052   1053        * Squelch our metadata.
  1053   1054        */
  1054   1055   
  1055   1056       if (clsPtr->metadataPtr != NULL) {
  1056   1057   	Tcl_ObjectMetadataType *metadataTypePtr;
  1057   1058   	ClientData value;
................................................................................
  1060   1061   	    metadataTypePtr->deleteProc(value);
  1061   1062   	}
  1062   1063   	Tcl_DeleteHashTable(clsPtr->metadataPtr);
  1063   1064   	ckfree(clsPtr->metadataPtr);
  1064   1065   	clsPtr->metadataPtr = NULL;
  1065   1066       }
  1066   1067   
  1067         -    FOREACH(tmpClsPtr, clsPtr->mixins) {
  1068         -	TclOORemoveFromMixinSubs(clsPtr, tmpClsPtr);
         1068  +    if (clsPtr->mixins.num) {
         1069  +	FOREACH(tmpClsPtr, clsPtr->mixins) {
         1070  +	    TclOORemoveFromMixinSubs(clsPtr, tmpClsPtr);
         1071  +	    TclOODecrRefCount(tmpClsPtr->thisPtr);
         1072  +	}
         1073  +	ckfree(clsPtr->mixins.list);
         1074  +	clsPtr->mixins.list = NULL;
         1075  +	clsPtr->mixins.num = 0;
  1069   1076       }
  1070         -    FOREACH(tmpClsPtr, clsPtr->superclasses) {
  1071         -	TclOORemoveFromSubclasses(clsPtr, tmpClsPtr);
         1077  +
         1078  +    if (clsPtr->superclasses.num > 0) {
         1079  +	FOREACH(tmpClsPtr, clsPtr->superclasses) {
         1080  +	    TclOORemoveFromSubclasses(clsPtr, tmpClsPtr);
         1081  +	    TclOODecrRefCount(tmpClsPtr->thisPtr);
         1082  +	}
         1083  +	ckfree(clsPtr->superclasses.list);
         1084  +	clsPtr->superclasses.num = 0;
         1085  +	clsPtr->superclasses.list = NULL;
  1072   1086       }
  1073   1087   
  1074   1088       FOREACH_HASH_VALUE(mPtr, &clsPtr->classMethods) {
  1075   1089   	TclOODelMethodRef(mPtr);
  1076   1090       }
  1077   1091       Tcl_DeleteHashTable(&clsPtr->classMethods);
  1078   1092       TclOODelMethodRef(clsPtr->constructorPtr);
................................................................................
  1200   1214   
  1201   1215       /*
  1202   1216        * TODO: Should this be protected with a * !IsRoot() condition?
  1203   1217        */
  1204   1218   
  1205   1219       TclOORemoveFromInstances(oPtr, oPtr->selfCls);
  1206   1220   
  1207         -    FOREACH(mixinPtr, oPtr->mixins) {
  1208         -	i -= TclOORemoveFromInstances(oPtr, mixinPtr);
  1209         -    }
  1210         -    if (i) {
         1221  +    if (oPtr->mixins.num > 0) {
         1222  +	FOREACH(mixinPtr, oPtr->mixins) {
         1223  +	    TclOORemoveFromInstances(oPtr, mixinPtr);
         1224  +	    TclOODecrRefCount(mixinPtr->thisPtr);
         1225  +	}
  1211   1226   	ckfree(oPtr->mixins.list);
  1212   1227       }
  1213   1228   
  1214   1229       FOREACH(filterObj, oPtr->filters) {
  1215   1230   	TclDecrRefCount(filterObj);
  1216   1231       }
  1217   1232       if (i) {
................................................................................
  1272   1287   	ReleaseClassContents(interp, oPtr);
  1273   1288       }
  1274   1289   
  1275   1290       /*
  1276   1291        * Delete the object structure itself.
  1277   1292        */
  1278   1293   
         1294  +    TclNsDecrRefCount((Namespace *)oPtr->namespacePtr);
  1279   1295       oPtr->namespacePtr = NULL;
         1296  +    TclOODecrRefCount(oPtr->selfCls->thisPtr);
  1280   1297       oPtr->selfCls = NULL;
  1281   1298       TclOODecrRefCount(oPtr);
  1282   1299       return;
  1283   1300   }
  1284   1301   
  1285   1302   /*
  1286   1303    * ----------------------------------------------------------------------
................................................................................
  1295   1312    */
  1296   1313   
  1297   1314   int
  1298   1315   TclOODecrRefCount(
  1299   1316       Object *oPtr)
  1300   1317   {
  1301   1318       if (oPtr->refCount-- <= 1) {
  1302         -	Class *clsPtr = oPtr->classPtr;
  1303   1319   
  1304   1320   	if (oPtr->classPtr != NULL) {
  1305         -	    ckfree(clsPtr->superclasses.list);
  1306         -	    ckfree(clsPtr->subclasses.list);
  1307         -	    ckfree(clsPtr->instances.list);
  1308         -	    ckfree(clsPtr->mixinSubs.list);
  1309         -	    ckfree(clsPtr->mixins.list);
  1310   1321   	    ckfree(oPtr->classPtr);
  1311   1322   	}
  1312   1323   	ckfree(oPtr);
  1313   1324   	return 1;
  1314   1325       }
  1315   1326       return 0;
  1316   1327   }
................................................................................
  1331   1342       Object *oPtr,		/* The instance to remove. */
  1332   1343       Class *clsPtr)		/* The class (possibly) containing the
  1333   1344   				 * reference to the instance. */
  1334   1345   {
  1335   1346       int i, res = 0;
  1336   1347       Object *instPtr;
  1337   1348   
  1338         -    if (Deleted(clsPtr->thisPtr)) {
  1339         -	return res;
  1340         -    }
  1341         -
  1342   1349       FOREACH(instPtr, clsPtr->instances) {
  1343   1350   	if (oPtr == instPtr) {
  1344   1351   	    RemoveItem(Object, clsPtr->instances, i);
  1345   1352   	    TclOODecrRefCount(oPtr);
  1346   1353   	    res++;
  1347   1354   	    break;
  1348   1355   	}
................................................................................
  1397   1404       Class *subPtr,		/* The subclass to remove. */
  1398   1405       Class *superPtr)		/* The superclass to possibly remove the
  1399   1406   				 * subclass reference from. */
  1400   1407   {
  1401   1408       int i, res = 0;
  1402   1409       Class *subclsPtr;
  1403   1410   
  1404         -    if (Deleted(superPtr->thisPtr)) {
  1405         -	return res;
  1406         -    }
  1407         -
  1408   1411       FOREACH(subclsPtr, superPtr->subclasses) {
  1409   1412   	if (subPtr == subclsPtr) {
  1410   1413   	    RemoveItem(Class, superPtr->subclasses, i);
  1411   1414   	    TclOODecrRefCount(subPtr->thisPtr);
  1412   1415   	    res++;
  1413   1416   	}
  1414   1417       }
................................................................................
  1465   1468       Class *subPtr,		/* The subclass to remove. */
  1466   1469       Class *superPtr)		/* The superclass to possibly remove the
  1467   1470   				 * subclass reference from. */
  1468   1471   {
  1469   1472       int i, res = 0;
  1470   1473       Class *subclsPtr;
  1471   1474   
  1472         -    if (Deleted(superPtr->thisPtr)) {
  1473         -	return res;
  1474         -    }
  1475         -
  1476   1475       FOREACH(subclsPtr, superPtr->mixinSubs) {
  1477   1476   	if (subPtr == subclsPtr) {
  1478   1477   	    RemoveItem(Class, superPtr->mixinSubs, i);
  1479   1478   	    TclOODecrRefCount(subPtr->thisPtr);
  1480   1479   	    res++;
  1481   1480   	    break;
  1482   1481   	}
................................................................................
  1776   1775   
  1777   1776       /*
  1778   1777        * Create the object.
  1779   1778        */
  1780   1779   
  1781   1780       oPtr = AllocObject(interp, simpleName, nsPtr, nsNameStr);
  1782   1781       oPtr->selfCls = classPtr;
         1782  +    AddRef(classPtr->thisPtr);
  1783   1783       TclOOAddToInstances(oPtr, classPtr);
  1784   1784   
  1785   1785       /*
  1786   1786        * Check to see if we're really creating a class. If so, allocate the
  1787   1787        * class structure as well.
  1788   1788        */
  1789   1789   
................................................................................
  1921   1921   	}
  1922   1922       }
  1923   1923   
  1924   1924       /*
  1925   1925        * Copy the object's mixin references to the new object.
  1926   1926        */
  1927   1927   
  1928         -    FOREACH(mixinPtr, o2Ptr->mixins) {
  1929         -	if (mixinPtr && mixinPtr != o2Ptr->selfCls) {
  1930         -	    TclOORemoveFromInstances(o2Ptr, mixinPtr);
         1928  +    if (o2Ptr->mixins.num != 0) {
         1929  +	FOREACH(mixinPtr, o2Ptr->mixins) {
         1930  +	    if (mixinPtr && mixinPtr != o2Ptr->selfCls) {
         1931  +		TclOORemoveFromInstances(o2Ptr, mixinPtr);
         1932  +	    }
         1933  +	    TclOODecrRefCount(mixinPtr->thisPtr);
  1931   1934   	}
         1935  +	ckfree(o2Ptr->mixins.list);
  1932   1936       }
  1933   1937       DUPLICATE(o2Ptr->mixins, oPtr->mixins, Class *);
  1934   1938       FOREACH(mixinPtr, o2Ptr->mixins) {
  1935   1939   	if (mixinPtr && mixinPtr != o2Ptr->selfCls) {
  1936   1940   	    TclOOAddToInstances(o2Ptr, mixinPtr);
  1937   1941   	}
         1942  +	/* For the reference just created in DUPLICATE */
         1943  +	AddRef(mixinPtr->thisPtr);
  1938   1944       }
  1939   1945   
  1940   1946       /*
  1941   1947        * Copy the object's filter list to the new object.
  1942   1948        */
  1943   1949   
  1944   1950       DUPLICATE(o2Ptr->filters, oPtr->filters, Tcl_Obj *);
................................................................................
  2008   2014   	/*
  2009   2015   	 * Ensure that the new class's superclass structure is the same as the
  2010   2016   	 * old class's.
  2011   2017   	 */
  2012   2018   
  2013   2019   	FOREACH(superPtr, cls2Ptr->superclasses) {
  2014   2020   	    TclOORemoveFromSubclasses(cls2Ptr, superPtr);
         2021  +	    TclOODecrRefCount(superPtr->thisPtr);
  2015   2022   	}
  2016   2023   	if (cls2Ptr->superclasses.num) {
  2017   2024   	    cls2Ptr->superclasses.list = ckrealloc(cls2Ptr->superclasses.list,
  2018   2025   		    sizeof(Class *) * clsPtr->superclasses.num);
  2019   2026   	} else {
  2020   2027   	    cls2Ptr->superclasses.list =
  2021   2028   		    ckalloc(sizeof(Class *) * clsPtr->superclasses.num);
  2022   2029   	}
  2023   2030   	memcpy(cls2Ptr->superclasses.list, clsPtr->superclasses.list,
  2024   2031   		sizeof(Class *) * clsPtr->superclasses.num);
  2025   2032   	cls2Ptr->superclasses.num = clsPtr->superclasses.num;
  2026   2033   	FOREACH(superPtr, cls2Ptr->superclasses) {
  2027   2034   	    TclOOAddToSubclasses(cls2Ptr, superPtr);
         2035  +
         2036  +	    /* For the new item in cls2Ptr->superclasses that memcpy just
         2037  +	     * created
         2038  +	     */
         2039  +	    AddRef(superPtr->thisPtr);
  2028   2040   	}
  2029   2041   
  2030   2042   	/*
  2031   2043   	 * Duplicate the source class's filters.
  2032   2044   	 */
  2033   2045   
  2034   2046   	DUPLICATE(cls2Ptr->filters, clsPtr->filters, Tcl_Obj *);
................................................................................
  2046   2058   	}
  2047   2059   
  2048   2060   	/*
  2049   2061   	 * Duplicate the source class's mixins (which cannot be circular
  2050   2062   	 * references to the duplicate).
  2051   2063   	 */
  2052   2064   
  2053         -	FOREACH(mixinPtr, cls2Ptr->mixins) {
  2054         -	    TclOORemoveFromMixinSubs(cls2Ptr, mixinPtr);
  2055         -	}
  2056   2065   	if (cls2Ptr->mixins.num != 0) {
         2066  +	    FOREACH(mixinPtr, cls2Ptr->mixins) {
         2067  +		TclOORemoveFromMixinSubs(cls2Ptr, mixinPtr);
         2068  +		TclOODecrRefCount(mixinPtr->thisPtr);
         2069  +	    }
  2057   2070   	    ckfree(clsPtr->mixins.list);
  2058   2071   	}
  2059   2072   	DUPLICATE(cls2Ptr->mixins, clsPtr->mixins, Class *);
  2060   2073   	FOREACH(mixinPtr, cls2Ptr->mixins) {
  2061   2074   	    TclOOAddToMixinSubs(cls2Ptr, mixinPtr);
         2075  +	    /* For the copy just created in DUPLICATE */
         2076  +	    AddRef(mixinPtr->thisPtr);
  2062   2077   	}
  2063   2078   
  2064   2079   	/*
  2065   2080   	 * Duplicate the source class's methods, constructor and destructor.
  2066   2081   	 */
  2067   2082   
  2068   2083   	FOREACH_HASH(keyPtr, mPtr, &clsPtr->classMethods) {

Changes to generic/tclOODefineCmds.c.

   328    328       Class *mixinPtr;
   329    329       int i;
   330    330   
   331    331       if (numMixins == 0) {
   332    332   	if (oPtr->mixins.num != 0) {
   333    333   	    FOREACH(mixinPtr, oPtr->mixins) {
   334    334   		TclOORemoveFromInstances(oPtr, mixinPtr);
          335  +		TclOODecrRefCount(mixinPtr->thisPtr);
   335    336   	    }
   336    337   	    ckfree(oPtr->mixins.list);
   337    338   	    oPtr->mixins.num = 0;
   338    339   	}
   339    340   	RecomputeClassCacheFlag(oPtr);
   340    341       } else {
   341    342   	if (oPtr->mixins.num != 0) {
   342    343   	    FOREACH(mixinPtr, oPtr->mixins) {
   343    344   		if (mixinPtr && mixinPtr != oPtr->selfCls) {
   344    345   		    TclOORemoveFromInstances(oPtr, mixinPtr);
   345    346   		}
          347  +		TclOODecrRefCount(mixinPtr->thisPtr);
   346    348   	    }
   347    349   	    oPtr->mixins.list = ckrealloc(oPtr->mixins.list,
   348    350   		    sizeof(Class *) * numMixins);
   349    351   	} else {
   350    352   	    oPtr->mixins.list = ckalloc(sizeof(Class *) * numMixins);
   351    353   	    oPtr->flags &= ~USE_CLASS_CACHE;
   352    354   	}
   353    355   	oPtr->mixins.num = numMixins;
   354    356   	memcpy(oPtr->mixins.list, mixins, sizeof(Class *) * numMixins);
   355    357   	FOREACH(mixinPtr, oPtr->mixins) {
   356    358   	    if (mixinPtr != oPtr->selfCls) {
   357    359   		TclOOAddToInstances(oPtr, mixinPtr);
   358         -
   359         -		/*
   360         -		 * Corresponding TclOODecrRefCount() is in the caller of this
   361         -		 * function. 
   362         -		 */
   363         -
   364         -		TclOODecrRefCount(mixinPtr->thisPtr);
          360  +		/* For the new copy created by memcpy */
          361  +		AddRef(mixinPtr->thisPtr);
   365    362   	    }
   366    363   	}
   367    364       }
   368    365       oPtr->epoch++;
   369    366   }
   370    367   
   371    368   /*
................................................................................
   388    385       Class *mixinPtr;
   389    386       int i;
   390    387   
   391    388       if (numMixins == 0) {
   392    389   	if (classPtr->mixins.num != 0) {
   393    390   	    FOREACH(mixinPtr, classPtr->mixins) {
   394    391   		TclOORemoveFromMixinSubs(classPtr, mixinPtr);
          392  +		TclOODecrRefCount(mixinPtr->thisPtr);
   395    393   	    }
   396    394   	    ckfree(classPtr->mixins.list);
   397    395   	    classPtr->mixins.num = 0;
   398    396   	}
   399    397       } else {
   400    398   	if (classPtr->mixins.num != 0) {
   401    399   	    FOREACH(mixinPtr, classPtr->mixins) {
   402    400   		TclOORemoveFromMixinSubs(classPtr, mixinPtr);
          401  +		TclOODecrRefCount(mixinPtr->thisPtr);
   403    402   	    }
   404    403   	    classPtr->mixins.list = ckrealloc(classPtr->mixins.list,
   405    404   		    sizeof(Class *) * numMixins);
   406    405   	} else {
   407    406   	    classPtr->mixins.list = ckalloc(sizeof(Class *) * numMixins);
   408    407   	}
   409    408   	classPtr->mixins.num = numMixins;
   410    409   	memcpy(classPtr->mixins.list, mixins, sizeof(Class *) * numMixins);
   411    410   	FOREACH(mixinPtr, classPtr->mixins) {
   412    411   	    TclOOAddToMixinSubs(classPtr, mixinPtr);
   413         -
   414         -	    /*
   415         -	     * Corresponding TclOODecrRefCount() is in the caller of this
   416         -	     * function.
   417         -	     */
   418         -
   419         -	    TclOODecrRefCount(mixinPtr->thisPtr);
          412  +	    /* For the new copy created by memcpy */
          413  +	    AddRef(mixinPtr->thisPtr);
   420    414   	}
   421    415       }
   422    416       BumpGlobalEpoch(interp, classPtr);
   423    417   }
   424    418   
   425    419   /*
   426    420    * ----------------------------------------------------------------------
................................................................................
  1182   1176   
  1183   1177       /*
  1184   1178        * Set the object's class.
  1185   1179        */
  1186   1180   
  1187   1181       if (oPtr->selfCls != clsPtr) {
  1188   1182   	TclOORemoveFromInstances(oPtr, oPtr->selfCls);
  1189         -
  1190         -	/*
  1191         -	 * Reference count already incremented a few lines up.
  1192         -	 */
  1193         -
         1183  +	TclOODecrRefCount(oPtr->selfCls->thisPtr);
  1194   1184   	oPtr->selfCls = clsPtr;
  1195         -
         1185  +	AddRef(oPtr->selfCls->thisPtr);
  1196   1186   	TclOOAddToInstances(oPtr, oPtr->selfCls);
         1187  +
  1197   1188   	if (oPtr->classPtr != NULL) {
  1198   1189   	    BumpGlobalEpoch(interp, oPtr->classPtr);
  1199   1190   	} else {
  1200   1191   	    oPtr->epoch++;
  1201   1192   	}
  1202   1193       }
  1203   1194       return TCL_OK;
................................................................................
  1652   1643   	if (!isInstanceMixin && TclOOIsReachable(oPtr->classPtr, clsPtr)) {
  1653   1644   	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
  1654   1645   		    "may not mix a class into itself", -1));
  1655   1646   	    Tcl_SetErrorCode(interp, "TCL", "OO", "SELF_MIXIN", NULL);
  1656   1647   	    goto freeAndError;
  1657   1648   	}
  1658   1649   	mixins[i-1] = clsPtr;
  1659         -
  1660         -	/*
  1661         -	 * Corresponding TclOODecrRefCount() is in TclOOObjectSetMixins,
  1662         -	 * TclOOClassSetMixinsk, or just below if this function fails.
  1663         -	 */
  1664         -
  1665         -	AddRef(mixins[i-1]->thisPtr);
  1666   1650       }
  1667   1651   
  1668   1652       if (isInstanceMixin) {
  1669   1653   	TclOOObjectSetMixins(oPtr, objc-1, mixins);
  1670   1654       } else {
  1671   1655   	TclOOClassSetMixins(interp, oPtr->classPtr, objc-1, mixins);
  1672   1656       }
  1673   1657   
  1674   1658       TclStackFree(interp, mixins);
  1675   1659       return TCL_OK;
  1676   1660   
  1677   1661     freeAndError:
  1678         -    while (--i > 0) {
  1679         -	TclOODecrRefCount(mixins[i]->thisPtr);
  1680         -    }
  1681   1662       TclStackFree(interp, mixins);
  1682   1663       return TCL_ERROR;
  1683   1664   }
  1684   1665   
  1685   1666   /*
  1686   1667    * ----------------------------------------------------------------------
  1687   1668    *
................................................................................
  2104   2085   	}
  2105   2086   	if (TclOOIsReachable(oPtr->classPtr, mixins[i])) {
  2106   2087   	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
  2107   2088   		    "may not mix a class into itself", -1));
  2108   2089   	    Tcl_SetErrorCode(interp, "TCL", "OO", "SELF_MIXIN", NULL);
  2109   2090   	    goto freeAndError;
  2110   2091   	}
  2111         -
  2112         -	/*
  2113         -	 * Corresponding TclOODecrRefCount() is in TclOOClassSetMixins, or
  2114         -	 * just below if this function fails.
  2115         -	 */
  2116         -
  2117         -	AddRef(mixins[i]->thisPtr);
  2118   2092       }
  2119   2093   
  2120   2094       TclOOClassSetMixins(interp, oPtr->classPtr, mixinc, mixins);
  2121   2095       TclStackFree(interp, mixins);
  2122   2096       return TCL_OK;
  2123   2097   
  2124   2098     freeAndError:
  2125         -    while (i-- > 0) {
  2126         -	TclOODecrRefCount(mixins[i]->thisPtr);
  2127         -    }
  2128   2099       TclStackFree(interp, mixins);
  2129   2100       return TCL_ERROR;
  2130   2101   }
  2131   2102   
  2132   2103   /*
  2133   2104    * ----------------------------------------------------------------------
  2134   2105    *
................................................................................
  2230   2201   	superclasses = ckrealloc(superclasses, sizeof(Class *));
  2231   2202   	if (TclOOIsReachable(oPtr->fPtr->classCls, oPtr->classPtr)) {
  2232   2203   	    superclasses[0] = oPtr->fPtr->classCls;
  2233   2204   	} else {
  2234   2205   	    superclasses[0] = oPtr->fPtr->objectCls;
  2235   2206   	}
  2236   2207   	superc = 1;
  2237         -
  2238         -	/*
  2239         -	 * Corresponding TclOODecrRefCount is near the end of this function.
  2240         -	 */
  2241         -
  2242   2208   	AddRef(superclasses[0]->thisPtr);
  2243   2209       } else {
  2244   2210   	for (i=0 ; i<superc ; i++) {
  2245   2211   	    superclasses[i] = GetClassInOuterContext(interp, superv[i],
  2246   2212   		    "only a class can be a superclass");
  2247   2213   	    if (superclasses[i] == NULL) {
  2248   2214   		i--;
................................................................................
  2284   2250        * it used to be a member of and splicing it into the new superclasses'
  2285   2251        * subclass list.
  2286   2252        */
  2287   2253   
  2288   2254       if (oPtr->classPtr->superclasses.num != 0) {
  2289   2255   	FOREACH(superPtr, oPtr->classPtr->superclasses) {
  2290   2256   	    TclOORemoveFromSubclasses(oPtr->classPtr, superPtr);
         2257  +	    TclOODecrRefCount(superPtr->thisPtr);
  2291   2258   	}
  2292   2259   	ckfree(oPtr->classPtr->superclasses.list);
  2293   2260       }
  2294   2261       oPtr->classPtr->superclasses.list = superclasses;
  2295   2262       oPtr->classPtr->superclasses.num = superc;
  2296   2263       FOREACH(superPtr, oPtr->classPtr->superclasses) {
  2297   2264   	TclOOAddToSubclasses(oPtr->classPtr, superPtr);
  2298         -
  2299         -	/*
  2300         -	 * To account for the AddRef() earlier in this function.
  2301         -	 */
  2302         -
  2303         -	TclOODecrRefCount(superPtr->thisPtr);
  2304   2265       }
  2305   2266       BumpGlobalEpoch(interp, oPtr->classPtr);
  2306   2267   
  2307   2268       return TCL_OK;
  2308   2269   }
  2309   2270   
  2310   2271   /*
................................................................................
  2590   2551   
  2591   2552       mixins = TclStackAlloc(interp, sizeof(Class *) * mixinc);
  2592   2553   
  2593   2554       for (i=0 ; i<mixinc ; i++) {
  2594   2555   	mixins[i] = GetClassInOuterContext(interp, mixinv[i],
  2595   2556   		"may only mix in classes");
  2596   2557   	if (mixins[i] == NULL) {
  2597         -	    while (i-- > 0) {
  2598         -		TclOODecrRefCount(mixins[i]->thisPtr);
  2599         -	    }
  2600   2558   	    TclStackFree(interp, mixins);
  2601   2559   	    return TCL_ERROR;
  2602   2560   	}
  2603         -
  2604         -	/*
  2605         -	 * Corresponding TclOODecrRefCount() is in TclOOObjectSetMixins() or
  2606         -	 * just above if this function fails.
  2607         -	 */
  2608         -
  2609         -	AddRef(mixins[i]->thisPtr);
  2610   2561       }
  2611   2562   
  2612   2563       TclOOObjectSetMixins(oPtr, mixinc, mixins);
  2613   2564       TclStackFree(interp, mixins);
  2614   2565       return TCL_OK;
  2615   2566   }
  2616   2567   

Changes to generic/tclPipe.c.

   217    217    */
   218    218   
   219    219   void
   220    220   Tcl_ReapDetachedProcs(void)
   221    221   {
   222    222       register Detached *detPtr;
   223    223       Detached *nextPtr, *prevPtr;
   224         -    int status;
   225         -    Tcl_Pid pid;
          224  +    int status, code;
   226    225   
   227    226       Tcl_MutexLock(&pipeMutex);
   228    227       for (detPtr = detList, prevPtr = NULL; detPtr != NULL; ) {
   229         -	pid = Tcl_WaitPid(detPtr->pid, &status, WNOHANG);
   230         -	if ((pid == 0) || ((pid == (Tcl_Pid) -1) && (errno != ECHILD))) {
          228  +	status = TclProcessWait(detPtr->pid, WNOHANG, &code, NULL, NULL);
          229  +	if (status == TCL_PROCESS_UNCHANGED || (status == TCL_PROCESS_ERROR
          230  +		&& code != ECHILD)) {
   231    231   	    prevPtr = detPtr;
   232    232   	    detPtr = detPtr->nextPtr;
   233    233   	    continue;
   234    234   	}
   235    235   	nextPtr = detPtr->nextPtr;
   236    236   	if (prevPtr == NULL) {
   237    237   	    detList = detPtr->nextPtr;
................................................................................
   273    273       Tcl_Pid *pidPtr,		/* Array of process ids of children. */
   274    274       Tcl_Channel errorChan)	/* Channel for file containing stderr output
   275    275   				 * from pipeline. NULL means there isn't any
   276    276   				 * stderr output. */
   277    277   {
   278    278       int result = TCL_OK;
   279    279       int i, abnormalExit, anyErrorInfo;
   280         -    Tcl_Pid pid;
   281         -    int waitStatus;
   282         -    const char *msg;
   283         -    unsigned long resolvedPid;
          280  +    TclProcessWaitStatus waitStatus;
          281  +    int code;
          282  +    Tcl_Obj *msg, *error;
   284    283   
   285    284       abnormalExit = 0;
   286    285       for (i = 0; i < numPids; i++) {
   287         -	/*
   288         -	 * We need to get the resolved pid before we wait on it as the windows
   289         -	 * implementation of Tcl_WaitPid deletes the information such that any
   290         -	 * following calls to TclpGetPid fail.
   291         -	 */
   292         -
   293         -	resolvedPid = TclpGetPid(pidPtr[i]);
   294         -	pid = Tcl_WaitPid(pidPtr[i], &waitStatus, 0);
   295         -	if (pid == (Tcl_Pid) -1) {
          286  +	waitStatus = TclProcessWait(pidPtr[i], 0, &code, &msg, &error);
          287  +	if (waitStatus == TCL_PROCESS_ERROR) {
   296    288   	    result = TCL_ERROR;
   297    289   	    if (interp != NULL) {
   298         -		msg = Tcl_PosixError(interp);
   299         -		if (errno == ECHILD) {
   300         -		    /*
   301         -		     * This changeup in message suggested by Mark Diekhans to
   302         -		     * remind people that ECHILD errors can occur on some
   303         -		     * systems if SIGCHLD isn't in its default state.
   304         -		     */
   305         -
   306         -		    msg =
   307         -			"child process lost (is SIGCHLD ignored or trapped?)";
   308         -		}
   309         -		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
   310         -			"error waiting for process to exit: %s", msg));
          290  +		Tcl_SetObjErrorCode(interp, error);
          291  +		Tcl_SetObjResult(interp, msg);
   311    292   	    }
          293  +	    Tcl_DecrRefCount(error);
          294  +	    Tcl_DecrRefCount(msg);
   312    295   	    continue;
   313    296   	}
   314    297   
   315    298   	/*
   316    299   	 * Create error messages for unusual process exits. An extra newline
   317    300   	 * gets appended to each error message, but it gets removed below (in
   318    301   	 * the same fashion that an extra newline in the command's output is
   319    302   	 * removed).
   320    303   	 */
   321    304   
   322         -	if (!WIFEXITED(waitStatus) || (WEXITSTATUS(waitStatus) != 0)) {
   323         -	    char msg1[TCL_INTEGER_SPACE], msg2[TCL_INTEGER_SPACE];
   324         -
          305  +	if (waitStatus != TCL_PROCESS_EXITED || code != 0) {
   325    306   	    result = TCL_ERROR;
   326         -	    sprintf(msg1, "%lu", resolvedPid);
   327         -	    if (WIFEXITED(waitStatus)) {
          307  +	    if (waitStatus == TCL_PROCESS_EXITED) {
   328    308   		if (interp != NULL) {
   329         -		    sprintf(msg2, "%u", WEXITSTATUS(waitStatus));
   330         -		    Tcl_SetErrorCode(interp, "CHILDSTATUS", msg1, msg2, NULL);
          309  +		    Tcl_SetObjErrorCode(interp, error);
   331    310   		}
   332    311   		abnormalExit = 1;
   333    312   	    } else if (interp != NULL) {
   334         -		const char *p;
   335         -
   336         -		if (WIFSIGNALED(waitStatus)) {
   337         -		    p = Tcl_SignalMsg(WTERMSIG(waitStatus));
   338         -		    Tcl_SetErrorCode(interp, "CHILDKILLED", msg1,
   339         -			    Tcl_SignalId(WTERMSIG(waitStatus)), p, NULL);
   340         -		    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
   341         -			    "child killed: %s\n", p));
   342         -		} else if (WIFSTOPPED(waitStatus)) {
   343         -		    p = Tcl_SignalMsg(WSTOPSIG(waitStatus));
   344         -		    Tcl_SetErrorCode(interp, "CHILDSUSP", msg1,
   345         -			    Tcl_SignalId(WSTOPSIG(waitStatus)), p, NULL);
   346         -		    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
   347         -			    "child suspended: %s\n", p));
   348         -		} else {
   349         -		    Tcl_SetObjResult(interp, Tcl_NewStringObj(
   350         -			    "child wait status didn't make sense\n", -1));
   351         -		    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC",
   352         -			    "ODDWAITRESULT", msg1, NULL);
   353         -		}
          313  +		Tcl_SetObjErrorCode(interp, error);
          314  +		Tcl_SetObjResult(interp, msg);
   354    315   	    }
          316  +	    Tcl_DecrRefCount(error);
          317  +	    Tcl_DecrRefCount(msg);
   355    318   	}
   356    319       }
   357    320   
   358    321       /*
   359    322        * Read the standard error file. If there's anything there, then return an
   360    323        * error and add the file's contents to the result string.
   361    324        */
................................................................................
   932    895   	if (result != TCL_OK) {
   933    896   	    goto error;
   934    897   	}
   935    898   	Tcl_DStringFree(&execBuffer);
   936    899   
   937    900   	pidPtr[numPids] = pid;
   938    901   	numPids++;
          902  +	TclProcessCreated(pid);
   939    903   
   940    904   	/*
   941    905   	 * Close off our copies of file descriptors that were set up for this
   942    906   	 * child, then set up the input for the next child.
   943    907   	 */
   944    908   
   945    909   	if ((curInFile != NULL) && (curInFile != inputFile)) {

Added generic/tclProcess.c.

            1  +/*
            2  + * tclProcess.c --
            3  + *
            4  + *	This file implements the "tcl::process" ensemble for subprocess 
            5  + *	management as defined by TIP #462.
            6  + *
            7  + * Copyright (c) 2017 Frederic Bonnet.
            8  + *
            9  + * See the file "license.terms" for information on usage and redistribution of
           10  + * this file, and for a DISCLAIMER OF ALL WARRANTIES.
           11  + */
           12  +
           13  +#include "tclInt.h"
           14  +
           15  +/*
           16  + * Autopurge flag. Process-global because of the way Tcl manages child 
           17  + * processes (see tclPipe.c).
           18  + */
           19  +
           20  +static int autopurge = 1;	/* Autopurge flag. */
           21  +
           22  +/*
           23  + * Hash tables that keeps track of all child process statuses. Keys are the 
           24  + * child process ids and resolved pids, values are (ProcessInfo *).
           25  + */
           26  +
           27  +typedef struct ProcessInfo {
           28  +    Tcl_Pid pid;		/* Process id. */
           29  +    int resolvedPid;		/* Resolved process id. */
           30  +    int purge;			/* Purge eventualy. */
           31  +    TclProcessWaitStatus status;/* Process status. */
           32  +    int code;			/* Error code, exit status or signal 
           33  +				   number. */
           34  +    Tcl_Obj *msg;		/* Error message. */
           35  +    Tcl_Obj *error;		/* Error code. */
           36  +} ProcessInfo;
           37  +static Tcl_HashTable infoTablePerPid;
           38  +static Tcl_HashTable infoTablePerResolvedPid;
           39  +static int infoTablesInitialized = 0;	/* 0 means not yet initialized. */
           40  +TCL_DECLARE_MUTEX(infoTablesMutex)
           41  +
           42  + /*
           43  + * Prototypes for functions defined later in this file:
           44  + */
           45  +
           46  +static void		InitProcessInfo(ProcessInfo *info, Tcl_Pid pid,
           47  +			    int resolvedPid);
           48  +static void		FreeProcessInfo(ProcessInfo *info);
           49  +static int		RefreshProcessInfo(ProcessInfo *info, int options);
           50  +static TclProcessWaitStatus WaitProcessStatus(Tcl_Pid pid, int resolvedPid, 
           51  +			    int options, int *codePtr, Tcl_Obj **msgPtr,
           52  +			    Tcl_Obj **errorObjPtr);
           53  +static Tcl_Obj *	BuildProcessStatusObj(ProcessInfo *info);
           54  +static int		ProcessListObjCmd(ClientData clientData,
           55  +			    Tcl_Interp *interp, int objc,
           56  +			    Tcl_Obj *const objv[]);
           57  +static int		ProcessStatusObjCmd(ClientData clientData,
           58  +			    Tcl_Interp *interp, int objc,
           59  +			    Tcl_Obj *const objv[]);
           60  +static int		ProcessPurgeObjCmd(ClientData clientData,
           61  +			    Tcl_Interp *interp, int objc,
           62  +			    Tcl_Obj *const objv[]);
           63  +static int		ProcessAutopurgeObjCmd(ClientData clientData,
           64  +			    Tcl_Interp *interp, int objc,
           65  +			    Tcl_Obj *const objv[]);
           66  +
           67  +/*
           68  + *----------------------------------------------------------------------
           69  + *
           70  + * InitProcessInfo --
           71  + *
           72  + *	Initializes the ProcessInfo structure.
           73  + *
           74  + * Results:
           75  + *	None.
           76  + *
           77  + * Side effects:
           78  + *	Memory written.
           79  + *
           80  + *----------------------------------------------------------------------
           81  + */
           82  +
           83  +void
           84  +InitProcessInfo(
           85  +    ProcessInfo *info,		/* Structure to initialize. */
           86  +    Tcl_Pid pid,		/* Process id. */
           87  +    int resolvedPid)		/* Resolved process id. */
           88  +{
           89  +    info->pid = pid;
           90  +    info->resolvedPid = resolvedPid;
           91  +    info->purge = 0;
           92  +    info->status = TCL_PROCESS_UNCHANGED;
           93  +    info->code = 0;
           94  +    info->msg = NULL;
           95  +    info->error = NULL;
           96  +}
           97  +
           98  +/*
           99  + *----------------------------------------------------------------------
          100  + *
          101  + * FreeProcessInfo --
          102  + *
          103  + *	Free the ProcessInfo structure.
          104  + *
          105  + * Results:
          106  + *	None.
          107  + *
          108  + * Side effects:
          109  + *	Memory deallocated, Tcl_Obj refcount decreased.
          110  + *
          111  + *----------------------------------------------------------------------
          112  + */
          113  +
          114  +void
          115  +FreeProcessInfo(
          116  +    ProcessInfo *info)		/* Structure to free. */
          117  +{
          118  +    /*
          119  +     * Free stored Tcl_Objs.
          120  +     */
          121  +
          122  +    if (info->msg) {
          123  +	Tcl_DecrRefCount(info->msg);
          124  +    }
          125  +    if (info->error) {
          126  +	Tcl_DecrRefCount(info->error);
          127  +    }
          128  +
          129  +    /*
          130  +     * Free allocated structure.
          131  +     */
          132  +
          133  +    ckfree(info);
          134  +}
          135  +
          136  +/*
          137  + *----------------------------------------------------------------------
          138  + *
          139  + * RefreshProcessInfo --
          140  + *
          141  + *	Refresh process info.
          142  + *
          143  + * Results:
          144  + *	Nonzero if state changed, else zero.
          145  + *
          146  + * Side effects:
          147  + *	May call WaitProcessStatus, which can block if WNOHANG option is set.
          148  + *
          149  + *----------------------------------------------------------------------
          150  + */
          151  +
          152  +int
          153  +RefreshProcessInfo(
          154  +    ProcessInfo *info,		/* Structure to refresh. */
          155  +    int options			/* Options passed to WaitProcessStatus. */
          156  +)
          157  +{
          158  +    if (info->status == TCL_PROCESS_UNCHANGED) {
          159  +	/*
          160  +	 * Refresh & store status.
          161  +	 */
          162  +
          163  +	info->status = WaitProcessStatus(info->pid, info->resolvedPid, 
          164  +		options, &info->code, &info->msg, &info->error);
          165  +	if (info->msg) Tcl_IncrRefCount(info->msg);
          166  +	if (info->error) Tcl_IncrRefCount(info->error);
          167  +	return (info->status != TCL_PROCESS_UNCHANGED);
          168  +    } else {
          169  +	/*
          170  +	 * No change.
          171  +	 */
          172  +
          173  +	return 0;
          174  +    }
          175  +}
          176  +
          177  +/*
          178  + *----------------------------------------------------------------------
          179  + *
          180  + * WaitProcessStatus --
          181  + *
          182  + *	Wait for process status to change.
          183  + *
          184  + * Results:
          185  + *	TclProcessWaitStatus enum value.
          186  + *
          187  + * Side effects:
          188  + *	May call WaitProcessStatus, which can block if WNOHANG option is set.
          189  + *
          190  + *----------------------------------------------------------------------
          191  + */
          192  +
          193  +TclProcessWaitStatus
          194  +WaitProcessStatus(
          195  +    Tcl_Pid pid,		/* Process id. */
          196  +    int resolvedPid,		/* Resolved process id. */
          197  +    int options,		/* Options passed to Tcl_WaitPid. */
          198  +    int *codePtr,		/* If non-NULL, will receive either:
          199  +				 *  - 0 for normal exit.
          200  +				 *  - errno in case of error.
          201  +				 *  - non-zero exit code for abormal exit.
          202  +				 *  - signal number if killed or suspended.
          203  +				 *  - Tcl_WaitPid status in all other cases.
          204  +				 */
          205  +    Tcl_Obj **msgObjPtr,	/* If non-NULL, will receive error message. */
          206  +    Tcl_Obj **errorObjPtr)	/* If non-NULL, will receive error code. */
          207  +{
          208  +    int waitStatus;
          209  +    Tcl_Obj *errorStrings[5];
          210  +    const char *msg;
          211  +
          212  +    pid = Tcl_WaitPid(pid, &waitStatus, options);
          213  +    if (pid == 0) {
          214  +	/*
          215  +	 * No change.
          216  +	 */
          217  +	
          218  +	return TCL_PROCESS_UNCHANGED;
          219  +    }
          220  +
          221  +    /*
          222  +     * Get process status.
          223  +     */
          224  +
          225  +    if (pid == (Tcl_Pid) -1) {
          226  +	/*
          227  +	 * POSIX errName msg
          228  +	 */
          229  +
          230  +	msg = Tcl_ErrnoMsg(errno);
          231  +	if (errno == ECHILD) {
          232  +	    /*
          233  +	     * This changeup in message suggested by Mark Diekhans to
          234  +	     * remind people that ECHILD errors can occur on some
          235  +	     * systems if SIGCHLD isn't in its default state.
          236  +	     */
          237  +
          238  +	    msg = "child process lost (is SIGCHLD ignored or trapped?)";
          239  +	}
          240  +	if (codePtr) *codePtr = errno;
          241  +	if (msgObjPtr) *msgObjPtr = Tcl_ObjPrintf(
          242  +		"error waiting for process to exit: %s", msg);
          243  +	if (errorObjPtr) {
          244  +	    errorStrings[0] = Tcl_NewStringObj("POSIX", -1);
          245  +	    errorStrings[1] = Tcl_NewStringObj(Tcl_ErrnoId(), -1);
          246  +	    errorStrings[2] = Tcl_NewStringObj(msg, -1);
          247  +	    *errorObjPtr = Tcl_NewListObj(3, errorStrings);
          248  +	}
          249  +	return TCL_PROCESS_ERROR;
          250  +    } else if (WIFEXITED(waitStatus)) {
          251  +	if (codePtr) *codePtr = WEXITSTATUS(waitStatus);
          252  +	if (!WEXITSTATUS(waitStatus)) {
          253  +	    /*
          254  +	     * Normal exit.
          255  +	     */
          256  +
          257  +	    if (msgObjPtr) *msgObjPtr = NULL;
          258  +	    if (errorObjPtr) *errorObjPtr = NULL;
          259  +	} else {
          260  +	    /*
          261  +	     * CHILDSTATUS pid code
          262  +	     *
          263  +	     * Child exited with a non-zero exit status.
          264  +	     */
          265  +
          266  +	    if (msgObjPtr) *msgObjPtr = Tcl_NewStringObj(
          267  +		    "child process exited abnormally", -1);
          268  +	    if (errorObjPtr) {
          269  +		errorStrings[0] = Tcl_NewStringObj("CHILDSTATUS", -1);
          270  +		errorStrings[1] = Tcl_NewIntObj(resolvedPid);
          271  +		errorStrings[2] = Tcl_NewIntObj(WEXITSTATUS(waitStatus));
          272  +		*errorObjPtr = Tcl_NewListObj(3, errorStrings);
          273  +	    }
          274  +	}
          275  +	return TCL_PROCESS_EXITED;
          276  +    } else if (WIFSIGNALED(waitStatus)) {
          277  +	/*
          278  +	 * CHILDKILLED pid sigName msg
          279  +	 *
          280  +	 * Child killed because of a signal.
          281  +	 */
          282  +
          283  +	msg = Tcl_SignalMsg(WTERMSIG(waitStatus));
          284  +	if (codePtr) *codePtr = WTERMSIG(waitStatus);
          285  +	if (msgObjPtr) *msgObjPtr = Tcl_ObjPrintf(
          286  +		"child killed: %s", msg);
          287  +	if (errorObjPtr) {
          288  +	    errorStrings[0] = Tcl_NewStringObj("CHILDKILLED", -1);
          289  +	    errorStrings[1] = Tcl_NewIntObj(resolvedPid);
          290  +	    errorStrings[2] = Tcl_NewStringObj(Tcl_SignalId(WTERMSIG(waitStatus)), -1);
          291  +	    errorStrings[3] = Tcl_NewStringObj(msg, -1);
          292  +	    *errorObjPtr = Tcl_NewListObj(4, errorStrings);
          293  +	}
          294  +	return TCL_PROCESS_SIGNALED;
          295  +    } else if (WIFSTOPPED(waitStatus)) {
          296  +	/*
          297  +	 * CHILDSUSP pid sigName msg
          298  +	 *
          299  +	 * Child suspended because of a signal.
          300  +	 */
          301  +
          302  +	msg = Tcl_SignalMsg(WSTOPSIG(waitStatus));
          303  +	if (codePtr) *codePtr = WSTOPSIG(waitStatus);
          304  +	if (msgObjPtr) *msgObjPtr = Tcl_ObjPrintf(
          305  +		"child suspended: %s", msg);
          306  +	if (errorObjPtr) {
          307  +	    errorStrings[0] = Tcl_NewStringObj("CHILDSUSP", -1);
          308  +	    errorStrings[1] = Tcl_NewIntObj(resolvedPid);
          309  +	    errorStrings[2] = Tcl_NewStringObj(Tcl_SignalId(WSTOPSIG(waitStatus)), -1);
          310  +	    errorStrings[3] = Tcl_NewStringObj(msg, -1);
          311  +	    *errorObjPtr = Tcl_NewListObj(4, errorStrings);
          312  +	}
          313  +	return TCL_PROCESS_STOPPED;
          314  +    } else {
          315  +	/*
          316  +	 * TCL OPERATION EXEC ODDWAITRESULT
          317  +	 *
          318  +	 * Child wait status didn't make sense.
          319  +	 */
          320  +
          321  +	if (codePtr) *codePtr = waitStatus;
          322  +	if (msgObjPtr) *msgObjPtr = Tcl_NewStringObj(
          323  +		"child wait status didn't make sense\n", -1);
          324  +	if (errorObjPtr) {
          325  +	    errorStrings[0] = Tcl_NewStringObj("TCL", -1);
          326  +	    errorStrings[1] = Tcl_NewStringObj("OPERATION", -1);
          327  +	    errorStrings[2] = Tcl_NewStringObj("EXEC", -1);
          328  +	    errorStrings[3] = Tcl_NewStringObj("ODDWAITRESULT", -1);
          329  +	    errorStrings[4] = Tcl_NewIntObj(resolvedPid);
          330  +	    *errorObjPtr = Tcl_NewListObj(5, errorStrings);
          331  +	}
          332  +	return TCL_PROCESS_UNKNOWN_STATUS;
          333  +    }
          334  +}
          335  +
          336  +
          337  +/*
          338  + *----------------------------------------------------------------------
          339  + *
          340  + * BuildProcessStatusObj --
          341  + *
          342  + *	Build a list object with process status. The first element is always
          343  + *	a standard Tcl return value, which can be either TCL_OK or TCL_ERROR.
          344  + *	In the latter case, the second element is the error message and the
          345  + *	third element is a Tcl error code (see tclvars).
          346  + *
          347  + * Results:
          348  + *	A list object.
          349  + *
          350  + * Side effects:
          351  + *	Tcl_Objs are created.
          352  + *
          353  + *----------------------------------------------------------------------
          354  + */
          355  +
          356  +Tcl_Obj *
          357  +BuildProcessStatusObj(
          358  +    ProcessInfo *info)
          359  +{
          360  +    Tcl_Obj *resultObjs[3];
          361  +
          362  +    if (info->status == TCL_PROCESS_UNCHANGED) {
          363  +	/*
          364  +	 * Process still running, return empty obj.
          365  +	 */
          366  +
          367  +	return Tcl_NewObj();
          368  +    }
          369  +    if (info->status == TCL_PROCESS_EXITED && info->code == 0) {
          370  +	/*
          371  +	 * Normal exit, return TCL_OK.
          372  +	 */
          373  +	
          374  +	return Tcl_NewIntObj(TCL_OK);
          375  +    }
          376  +
          377  +    /*
          378  +     * Abnormal exit, return {TCL_ERROR msg error}
          379  +     */
          380  +
          381  +    resultObjs[0] = Tcl_NewIntObj(TCL_ERROR);
          382  +    resultObjs[1] = info->msg;
          383  +    resultObjs[2] = info->error;
          384  +    return Tcl_NewListObj(3, resultObjs);
          385  +}
          386  +
          387  +/*----------------------------------------------------------------------
          388  + *
          389  + * ProcessListObjCmd --
          390  + *
          391  + *	This function implements the 'tcl::process list' Tcl command. 
          392  + *	Refer to the user documentation for details on what it does.
          393  + *
          394  + * Results:
          395  + *	Returns a standard Tcl result.
          396  + *
          397  + * Side effects:
          398  + *	Access to the internal structures is protected by infoTablesMutex.
          399  + *
          400  + *----------------------------------------------------------------------
          401  + */
          402  +
          403  +static int
          404  +ProcessListObjCmd(
          405  +    ClientData clientData,	/* Not used. */
          406  +    Tcl_Interp *interp,		/* Current interpreter. */
          407  +    int objc,			/* Number of arguments. */
          408  +    Tcl_Obj *const objv[])	/* Argument objects. */
          409  +{
          410  +    Tcl_Obj *list;
          411  +    Tcl_HashEntry *entry;
          412  +    Tcl_HashSearch search;
          413  +    ProcessInfo *info;
          414  +
          415  +    if (objc != 1) {
          416  +	Tcl_WrongNumArgs(interp, 1, objv, NULL);
          417  +	return TCL_ERROR;
          418  +    }
          419  +
          420  +    /*
          421  +     * Return the list of all chid process ids.
          422  +     */
          423  +
          424  +    list = Tcl_NewListObj(0, NULL);
          425  +    Tcl_MutexLock(&infoTablesMutex);
          426  +    for (entry = Tcl_FirstHashEntry(&infoTablePerResolvedPid, &search); 
          427  +	    entry != NULL; entry = Tcl_NextHashEntry(&search)) {
          428  +	info = (ProcessInfo *) Tcl_GetHashValue(entry);
          429  +	Tcl_ListObjAppendElement(interp, list, 
          430  +		Tcl_NewIntObj(info->resolvedPid));
          431  +    }
          432  +    Tcl_MutexUnlock(&infoTablesMutex);
          433  +    Tcl_SetObjResult(interp, list);
          434  +    return TCL_OK;
          435  +}
          436  +
          437  +/*----------------------------------------------------------------------
          438  + *
          439  + * ProcessStatusObjCmd --
          440  + *
          441  + *	This function implements the 'tcl::process status' Tcl command. 
          442  + *	Refer to the user documentation for details on what it does.
          443  + *
          444  + * Results:
          445  + *	Returns a standard Tcl result.
          446  + *
          447  + * Side effects:
          448  + *	Access to the internal structures is protected by infoTablesMutex.
          449  + *	Calls RefreshProcessInfo, which can block if -wait switch is given.
          450  + *
          451  + *----------------------------------------------------------------------
          452  + */
          453  +
          454  +static int
          455  +ProcessStatusObjCmd(
          456  +    ClientData clientData,	/* Not used. */
          457  +    Tcl_Interp *interp,		/* Current interpreter. */
          458  +    int objc,			/* Number of arguments. */
          459  +    Tcl_Obj *const objv[])	/* Argument objects. */
          460  +{
          461  +    Tcl_Obj *dict;
          462  +    int index, options = WNOHANG;
          463  +    Tcl_HashEntry *entry;
          464  +    Tcl_HashSearch search;
          465  +    ProcessInfo *info;
          466  +    int numPids;
          467  +    Tcl_Obj **pidObjs;
          468  +    int result;
          469  +    int i;
          470  +    int pid;
          471  +    Tcl_Obj *const *savedobjv = objv;
          472  +    static const char *const switches[] = {
          473  +	"-wait", "--", NULL
          474  +    };
          475  +    enum switches {
          476  +	STATUS_WAIT, STATUS_LAST
          477  +    };
          478  +
          479  +    while (objc > 1) {
          480  +	if (TclGetString(objv[1])[0] != '-') {
          481  +	    break;
          482  +	}
          483  +	if (Tcl_GetIndexFromObj(interp, objv[1], switches, "switches", 0,
          484  +		&index) != TCL_OK) {
          485  +	    return TCL_ERROR;
          486  +	}
          487  +	++objv; --objc;
          488  +	if (STATUS_WAIT == (enum switches) index) {
          489  +	    options = 0;
          490  +	} else {
          491  +	    break;
          492  +	}
          493  +    }
          494  +
          495  +    if (objc != 1 && objc != 2) {
          496  +	Tcl_WrongNumArgs(interp, 1, savedobjv, "?switches? ?pids?");
          497  +	return TCL_ERROR;
          498  +    }
          499  +
          500  +    if (objc == 1) {
          501  +	/*
          502  +	* Return a dict with all child process statuses.
          503  +	*/
          504  +
          505  +	dict = Tcl_NewDictObj();
          506  +	Tcl_MutexLock(&infoTablesMutex);
          507  +	for (entry = Tcl_FirstHashEntry(&infoTablePerResolvedPid, &search); 
          508  +		entry != NULL; entry = Tcl_NextHashEntry(&search)) {
          509  +	    info = (ProcessInfo *) Tcl_GetHashValue(entry);
          510  +	    RefreshProcessInfo(info, options);
          511  +
          512  +	    if (info->purge && autopurge) {
          513  +		/*
          514  +		 * Purge entry.
          515  +		 */
          516  +		
          517  +		Tcl_DeleteHashEntry(entry);
          518  +		entry = Tcl_FindHashEntry(&infoTablePerPid, info->pid);
          519  +		Tcl_DeleteHashEntry(entry);
          520  +		FreeProcessInfo(info);
          521  +	    } else {
          522  +		/*
          523  +		 * Add to result.
          524  +		 */
          525  +
          526  +		Tcl_DictObjPut(interp, dict, Tcl_NewIntObj(info->resolvedPid), 
          527  +			BuildProcessStatusObj(info));
          528  +	    }
          529  +	}
          530  +	Tcl_MutexUnlock(&infoTablesMutex);
          531  +    } else {
          532  +	/*
          533  +	 * Only return statuses of provided processes.
          534  +	 */
          535  +	
          536  +	result = Tcl_ListObjGetElements(interp, objv[1], &numPids, &pidObjs);
          537  +	if (result != TCL_OK) {
          538  +	    return result;
          539  +	}
          540  +	dict = Tcl_NewDictObj();
          541  +	Tcl_MutexLock(&infoTablesMutex);
          542  +	for (i = 0; i < numPids; i++) {
          543  +	    result = Tcl_GetIntFromObj(interp, pidObjs[i], (int *) &pid);
          544  +	    if (result != TCL_OK) {
          545  +		Tcl_MutexUnlock(&infoTablesMutex);
          546  +		Tcl_DecrRefCount(dict);
          547  +		return result;
          548  +	    }
          549  +
          550  +	    entry = Tcl_FindHashEntry(&infoTablePerResolvedPid, INT2PTR(pid));
          551  +	    if (!entry) {
          552  +		/*
          553  +		 * Skip unknown process.
          554  +		 */
          555  +		
          556  +		continue;
          557  +	    }
          558  +	    
          559  +	    info = (ProcessInfo *) Tcl_GetHashValue(entry);
          560  +	    RefreshProcessInfo(info, options);
          561  +
          562  +	    if (info->purge && autopurge) {
          563  +		/*
          564  +		 * Purge entry.
          565  +		 */
          566  +		
          567  +		Tcl_DeleteHashEntry(entry);
          568  +		entry = Tcl_FindHashEntry(&infoTablePerPid, info->pid);
          569  +		Tcl_DeleteHashEntry(entry);
          570  +		FreeProcessInfo(info);
          571  +	    } else {
          572  +		/*
          573  +		 * Add to result.
          574  +		 */
          575  +
          576  +		Tcl_DictObjPut(interp, dict, Tcl_NewIntObj(info->resolvedPid), 
          577  +			BuildProcessStatusObj(info));
          578  +	    }
          579  +	}
          580  +	Tcl_MutexUnlock(&infoTablesMutex);
          581  +    }
          582  +    Tcl_SetObjResult(interp, dict);
          583  +    return TCL_OK;
          584  +}
          585  +
          586  +/*----------------------------------------------------------------------
          587  + *
          588  + * ProcessPurgeObjCmd --
          589  + *
          590  + *	This function implements the 'tcl::process purge' Tcl command. 
          591  + *	Refer to the user documentation for details on what it does.
          592  + *
          593  + * Results:
          594  + *	Returns a standard Tcl result.
          595  + *
          596  + * Side effects:
          597  + *	Frees all ProcessInfo structures with their purge flag set.
          598  + *
          599  + *----------------------------------------------------------------------
          600  + */
          601  +
          602  +static int
          603  +ProcessPurgeObjCmd(
          604  +    ClientData clientData,	/* Not used. */
          605  +    Tcl_Interp *interp,		/* Current interpreter. */
          606  +    int objc,			/* Number of arguments. */
          607  +    Tcl_Obj *const objv[])	/* Argument objects. */
          608  +{
          609  +    Tcl_HashEntry *entry;
          610  +    Tcl_HashSearch search;
          611  +    ProcessInfo *info;
          612  +    int numPids;
          613  +    Tcl_Obj **pidObjs;
          614  +    int result;
          615  +    int i;
          616  +    int pid;
          617  +
          618  +    if (objc != 1 && objc != 2) {
          619  +	Tcl_WrongNumArgs(interp, 1, objv, "?pids?");
          620  +	return TCL_ERROR;
          621  +    }
          622  +
          623  +    /*
          624  +     * First reap detached procs so that their purge flag is up-to-date.
          625  +     */
          626  +
          627  +    Tcl_ReapDetachedProcs();
          628  +
          629  +    if (objc == 1) {
          630  +	/*
          631  +	 * Purge all terminated processes.
          632  +	 */
          633  +
          634  +	Tcl_MutexLock(&infoTablesMutex);
          635  +	for (entry = Tcl_FirstHashEntry(&infoTablePerResolvedPid, &search); 
          636  +		entry != NULL; entry = Tcl_NextHashEntry(&search)) {
          637  +	    info = (ProcessInfo *) Tcl_GetHashValue(entry);
          638  +	    if (info->purge) {
          639  +		Tcl_DeleteHashEntry(entry);
          640  +		entry = Tcl_FindHashEntry(&infoTablePerPid, info->pid);
          641  +		Tcl_DeleteHashEntry(entry);
          642  +		FreeProcessInfo(info);
          643  +	    }
          644  +	}
          645  +	Tcl_MutexUnlock(&infoTablesMutex);
          646  +    } else {
          647  +	/*
          648  +	 * Purge only provided processes.
          649  +	 */
          650  +	
          651  +	result = Tcl_ListObjGetElements(interp, objv[1], &numPids, &pidObjs);
          652  +	if (result != TCL_OK) {
          653  +	    return result;
          654  +	}
          655  +	Tcl_MutexLock(&infoTablesMutex);
          656  +	for (i = 0; i < numPids; i++) {
          657  +	    result = Tcl_GetIntFromObj(interp, pidObjs[i], (int *) &pid);
          658  +	    if (result != TCL_OK) {
          659  +		Tcl_MutexUnlock(&infoTablesMutex);
          660  +		return result;
          661  +	    }
          662  +
          663  +	    entry = Tcl_FindHashEntry(&infoTablePerResolvedPid, INT2PTR(pid));
          664  +	    if (!entry) {
          665  +		/*
          666  +		 * Skip unknown process.
          667  +		 */
          668  +		
          669  +		continue;
          670  +	    }
          671  +
          672  +	    info = (ProcessInfo *) Tcl_GetHashValue(entry);
          673  +	    if (info->purge) {
          674  +		Tcl_DeleteHashEntry(entry);
          675  +		entry = Tcl_FindHashEntry(&infoTablePerPid, info->pid);
          676  +		Tcl_DeleteHashEntry(entry);
          677  +		FreeProcessInfo(info);
          678  +	    }
          679  +	}
          680  +	Tcl_MutexUnlock(&infoTablesMutex);
          681  +    }
          682  +
          683  +    return TCL_OK;
          684  +}
          685  +
          686  +/*----------------------------------------------------------------------
          687  + *
          688  + * ProcessAutopurgeObjCmd --
          689  + *
          690  + *	This function implements the 'tcl::process autopurge' Tcl command. 
          691  + *	Refer to the user documentation for details on what it does.
          692  + *
          693  + * Results:
          694  + *	Returns a standard Tcl result.
          695  + *
          696  + * Side effects:
          697  + *	Alters detached process handling by Tcl_ReapDetachedProcs().
          698  + *
          699  + *----------------------------------------------------------------------
          700  + */
          701  +
          702  +static int
          703  +ProcessAutopurgeObjCmd(
          704  +    ClientData clientData,	/* Not used. */
          705  +    Tcl_Interp *interp,		/* Current interpreter. */
          706  +    int objc,			/* Number of arguments. */
          707  +    Tcl_Obj *const objv[])	/* Argument objects. */
          708  +{
          709  +    if (objc != 1 && objc != 2) {
          710  +	Tcl_WrongNumArgs(interp, 1, objv, "?flag?");
          711  +	return TCL_ERROR;
          712  +    }
          713  +
          714  +    if (objc == 2) {
          715  +	/*
          716  +	 * Set given value.
          717  +	 */
          718  +	
          719  +	int flag;
          720  +	int result = Tcl_GetBooleanFromObj(interp, objv[1], &flag);
          721  +	if (result != TCL_OK) {
          722  +	    return result;
          723  +	}
          724  +
          725  +	autopurge = !!flag;
          726  +    }
          727  +
          728  +    /* 
          729  +     * Return current value. 
          730  +     */
          731  +
          732  +    Tcl_SetObjResult(interp, Tcl_NewBooleanObj(autopurge));
          733  +    return TCL_OK;
          734  +}
          735  +
          736  +/*
          737  + *----------------------------------------------------------------------
          738  + *
          739  + * TclInitProcessCmd --
          740  + *
          741  + *	This procedure creates the "tcl::process" Tcl command. See the user
          742  + *	documentation for details on what it does.
          743  + *
          744  + * Results:
          745  + *	A standard Tcl result.
          746  + *
          747  + * Side effects:
          748  + *	See the user documentation.
          749  + *
          750  + *----------------------------------------------------------------------
          751  + */
          752  +
          753  +Tcl_Command
          754  +TclInitProcessCmd(
          755  +    Tcl_Interp *interp)		/* Current interpreter. */
          756  +{
          757  +    static const EnsembleImplMap processImplMap[] = {
          758  +	{"list", ProcessListObjCmd, TclCompileBasic0ArgCmd, NULL, NULL, 1},
          759  +	{"status", ProcessStatusObjCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 1},
          760  +	{"purge", ProcessPurgeObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1},
          761  +	{"autopurge", ProcessAutopurgeObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1},
          762  +	{NULL, NULL, NULL, NULL, NULL, 0}
          763  +    };
          764  +    Tcl_Command processCmd;
          765  +
          766  +    if (infoTablesInitialized == 0) {
          767  +	Tcl_MutexLock(&infoTablesMutex);
          768  +	if (infoTablesInitialized == 0) {
          769  +	    Tcl_InitHashTable(&infoTablePerPid, TCL_ONE_WORD_KEYS);
          770  +	    Tcl_InitHashTable(&infoTablePerResolvedPid, TCL_ONE_WORD_KEYS);
          771  +	    infoTablesInitialized = 1;
          772  +	}
          773  +	Tcl_MutexUnlock(&infoTablesMutex);
          774  +    }
          775  +
          776  +    processCmd = TclMakeEnsemble(interp, "::tcl::process", processImplMap);
          777  +    Tcl_Export(interp, Tcl_FindNamespace(interp, "::tcl", NULL, 0),
          778  +	    "process", 0);
          779  +    return processCmd;
          780  +}
          781  +
          782  +/*
          783  + *----------------------------------------------------------------------
          784  + *
          785  + * TclProcessCreated --
          786  + *
          787  + *	Called when a child process has been created by Tcl.
          788  + *
          789  + * Results:
          790  + *	None.
          791  + *
          792  + * Side effects:
          793  + *	Internal structures are updated with a new ProcessInfo.
          794  + *
          795  + *----------------------------------------------------------------------
          796  + */
          797  +
          798  +void
          799  +TclProcessCreated(
          800  +    Tcl_Pid pid)		/* Process id. */
          801  +{
          802  +    int resolvedPid;
          803  +    Tcl_HashEntry *entry, *entry2;
          804  +    int isNew;
          805  +    ProcessInfo *info;
          806  +
          807  +    /*
          808  +     * Get resolved pid first.
          809  +     */
          810  +
          811  +    resolvedPid = TclpGetPid(pid);
          812  +
          813  +    Tcl_MutexLock(&infoTablesMutex);
          814  +
          815  +    /*
          816  +     * Create entry in pid table.
          817  +     */
          818  +
          819  +    entry = Tcl_CreateHashEntry(&infoTablePerPid, pid, &isNew);
          820  +    if (!isNew) {
          821  +	/*
          822  +	 * Pid was reused, free old info and reuse structure.
          823  +	 */
          824  +	
          825  +	info = (ProcessInfo *) Tcl_GetHashValue(entry);
          826  +	entry2 = Tcl_FindHashEntry(&infoTablePerResolvedPid, 
          827  +		INT2PTR(resolvedPid));
          828  +	if (entry2) Tcl_DeleteHashEntry(entry2);
          829  +	FreeProcessInfo(info);
          830  +    }
          831  +
          832  +    /*
          833  +     * Allocate and initialize info structure.
          834  +     */
          835  +
          836  +    info = (ProcessInfo *) ckalloc(sizeof(ProcessInfo));
          837  +    InitProcessInfo(info, pid, resolvedPid);
          838  +
          839  +    /*
          840  +     * Add entry to tables.
          841  +     */
          842  +
          843  +    Tcl_SetHashValue(entry, info);
          844  +    entry = Tcl_CreateHashEntry(&infoTablePerResolvedPid, INT2PTR(resolvedPid),
          845  +	    &isNew);
          846  +    Tcl_SetHashValue(entry, info);
          847  +
          848  +    Tcl_MutexUnlock(&infoTablesMutex);
          849  +}
          850  +
          851  +/*
          852  + *----------------------------------------------------------------------
          853  + *
          854  + * TclProcessWait --
          855  + *
          856  + *	Wait for process status to change.
          857  + *
          858  + * Results:
          859  + *	TclProcessWaitStatus enum value.
          860  + *
          861  + * Side effects:
          862  + *	Completed process info structures are purged immediately (autopurge on)
          863  + *	or eventually (autopurge off).
          864  + *
          865  + *----------------------------------------------------------------------
          866  + */
          867  +
          868  +TclProcessWaitStatus
          869  +TclProcessWait(
          870  +    Tcl_Pid pid,		/* Process id. */
          871  +    int options,		/* Options passed to WaitProcessStatus. */
          872  +    int *codePtr,		/* If non-NULL, will receive either:
          873  +				 *  - 0 for normal exit.
          874  +				 *  - errno in case of error.
          875  +				 *  - non-zero exit code for abormal exit.
          876  +				 *  - signal number if killed or suspended.
          877  +				 *  - Tcl_WaitPid status in all other cases.
          878  +				 */
          879  +    Tcl_Obj **msgObjPtr,	/* If non-NULL, will receive error message. */
          880  +    Tcl_Obj **errorObjPtr)	/* If non-NULL, will receive error code. */
          881  +{
          882  +    Tcl_HashEntry *entry;
          883  +    ProcessInfo *info;
          884  +    TclProcessWaitStatus result;
          885  +
          886  +    /*
          887  +     * First search for pid in table.
          888  +     */
          889  +
          890  +    entry = Tcl_FindHashEntry(&infoTablePerPid, pid);
          891  +    if (!entry) {
          892  +	/*
          893  +	 * Unknown process, just call WaitProcessStatus and return.
          894  +	 */
          895  +	
          896  +	result = WaitProcessStatus(pid, TclpGetPid(pid), options, codePtr, 
          897  +		msgObjPtr, errorObjPtr);
          898  +	if (msgObjPtr && *msgObjPtr) Tcl_IncrRefCount(*msgObjPtr);
          899  +	if (errorObjPtr && *errorObjPtr) Tcl_IncrRefCount(*errorObjPtr);
          900  +	return result;
          901  +    }
          902  +
          903  +    info = (ProcessInfo *) Tcl_GetHashValue(entry);
          904  +    if (info->purge) {
          905  +	/*
          906  +	 * Process has completed but TclProcessWait has already been called,
          907  +	 * so report no change.
          908  +	 */
          909  +	
          910  +	return TCL_PROCESS_UNCHANGED;
          911  +    }
          912  +
          913  +    RefreshProcessInfo(info, options);
          914  +    if (info->status == TCL_PROCESS_UNCHANGED) {
          915  +	/*
          916  +	 * No change, stop there.
          917  +	 */
          918  +	
          919  +	return TCL_PROCESS_UNCHANGED;
          920  +    }
          921  +
          922  +    /*
          923  +     * Set return values.
          924  +     */
          925  +
          926  +    result = info->status;
          927  +    if (codePtr) *codePtr = info->code;
          928  +    if (msgObjPtr) *msgObjPtr = info->msg;
          929  +    if (errorObjPtr) *errorObjPtr = info->error;
          930  +    if (msgObjPtr && *msgObjPtr) Tcl_IncrRefCount(*msgObjPtr);
          931  +    if (errorObjPtr && *errorObjPtr) Tcl_IncrRefCount(*errorObjPtr);
          932  +
          933  +    if (autopurge) {
          934  +	/*
          935  +	 * Purge now.
          936  +	 */
          937  +
          938  +	Tcl_DeleteHashEntry(entry);
          939  +	entry = Tcl_FindHashEntry(&infoTablePerResolvedPid, 
          940  +		INT2PTR(info->resolvedPid));
          941  +	Tcl_DeleteHashEntry(entry);
          942  +	FreeProcessInfo(info);
          943  +    } else {
          944  +	/*
          945  +	 * Eventually purge. Subsequent calls will return
          946  +	 * TCL_PROCESS_UNCHANGED.
          947  +	 */
          948  +
          949  +	info->purge = 1;
          950  +    }
          951  +    return result;
          952  +}

Changes to generic/tclStringObj.c.

    34     34    * this file, and for a DISCLAIMER OF ALL WARRANTIES.
    35     35    */
    36     36   
    37     37   #include "tclInt.h"
    38     38   #include "tommath.h"
    39     39   #include "tclStringRep.h"
    40     40   
           41  +#include "assert.h"
    41     42   /*
    42     43    * Prototypes for functions defined later in this file:
    43     44    */
    44     45   
    45     46   static void		AppendPrintfToObjVA(Tcl_Obj *objPtr,
    46     47   			    const char *format, va_list argList);
    47     48   static void		AppendUnicodeToUnicodeRep(Tcl_Obj *objPtr,
................................................................................
  3523   3524   	}
  3524   3525   	/* Pass 2. Reverse all the bytes. */
  3525   3526   	ReverseBytes((unsigned char *)to, (unsigned char *)from, numBytes);
  3526   3527       }
  3527   3528   
  3528   3529       return objPtr;
  3529   3530   }
         3531  +
         3532  +/*
         3533  + *---------------------------------------------------------------------------
         3534  + *
         3535  + * TclStringReplace --
         3536  + *
         3537  + *	Implements the inner engine of the [string replace] command.
         3538  + *
         3539  + *	The result is a concatenation of a prefix from objPtr, characters
         3540  + *	0 through first-1, the insertPtr string value, and a suffix from
         3541  + *	objPtr, characters from first + count to the end. The effect is
         3542  + *	as if the inner substring of characters first through first+count-1
         3543  + *	are removed and replaced with insertPtr.
         3544  + *	If insertPtr is NULL, it is treated as an empty string.
         3545  + *	When passed the flag TCL_STRING_IN_PLACE, this routine will try
         3546  + *	to do the work within objPtr, so long as no sharing forbids it.
         3547  + *	Without that request, or as needed, a new Tcl value will be allocated
         3548  + *	to be the result.
         3549  + *
         3550  + * Results:
         3551  + *	A Tcl value that is the result of the substring replacement.
         3552  + *	May return NULL in case of an error. When NULL is returned and
         3553  + *	interp is non-NULL, error information is left in interp
         3554  + *
         3555  + *---------------------------------------------------------------------------
         3556  + */
         3557  +
         3558  +Tcl_Obj *
         3559  +TclStringReplace(
         3560  +    Tcl_Interp *interp,		/* For error reporting, may be NULL */
         3561  +    Tcl_Obj *objPtr,		/* String to act upon */
         3562  +    int first,			/* First index to replace */
         3563  +    int count,			/* How many chars to replace */
         3564  +    Tcl_Obj *insertPtr,		/* Replacement string, may be NULL */
         3565  +    int flags)			/* TCL_STRING_IN_PLACE => attempt in-place */
         3566  +{
         3567  +    int inPlace = flags & TCL_STRING_IN_PLACE;
         3568  +    Tcl_Obj *result;
         3569  +
         3570  +    /* Caller is expected to pass sensible arguments */
         3571  +    assert ( count >= 0 ) ;
         3572  +    assert ( first >= 0 ) ;
         3573  +
         3574  +    /* Replace nothing with nothing */
         3575  +    if ((insertPtr == NULL) && (count == 0)) {
         3576  +	if (inPlace) {
         3577  +	    return objPtr;
         3578  +	} else {
         3579  +	    return Tcl_DuplicateObj(objPtr);
         3580  +	}
         3581  +    }
         3582  +
         3583  +    /*
         3584  +     * The caller very likely had to call Tcl_GetCharLength() or similar
         3585  +     * to be able to process index values.  This means it is like that
         3586  +     * objPtr is either a proper "bytearray" or a "string" or else it has
         3587  +     * a known and short string rep.
         3588  +     */
         3589  +
         3590  +    if (TclIsPureByteArray(objPtr)) {
         3591  +	int numBytes;
         3592  +	unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, &numBytes);
         3593  +
         3594  +	if (insertPtr == NULL) {
         3595  +	    /* Replace something with nothing. */
         3596  +
         3597  +	    assert ( first <= numBytes ) ;
         3598  +	    assert ( count <= numBytes ) ;
         3599  +	    assert ( first + count <= numBytes ) ;
         3600  +
         3601  +	    result = Tcl_NewByteArrayObj(NULL, numBytes - count);/* PANIC? */
         3602  +	    TclAppendBytesToByteArray(result, bytes, first);
         3603  +	    TclAppendBytesToByteArray(result, bytes + first + count,
         3604  +		    numBytes - count - first);
         3605  +	    return result;
         3606  +	}
         3607  +
         3608  +	/* Replace everything */
         3609  +	if ((first == 0) && (count == numBytes)) {
         3610  +	    return insertPtr;
         3611  +	}
         3612  +
         3613  +	if (TclIsPureByteArray(insertPtr)) {
         3614  +	    int newBytes;
         3615  +	    unsigned char *iBytes
         3616  +		    = Tcl_GetByteArrayFromObj(insertPtr, &newBytes);
         3617  +
         3618  +	    if (count == newBytes && inPlace && !Tcl_IsShared(objPtr)) {
         3619  +		/*
         3620  +		 * Removal count and replacement count are equal.
         3621  +		 * Other conditions permit. Do in-place splice.
         3622  +		 */
         3623  +
         3624  +		memcpy(bytes + first, iBytes, count);
         3625  +		Tcl_InvalidateStringRep(objPtr);
         3626  +		return objPtr;
         3627  +	    }
         3628  +
         3629  +	    if (newBytes > INT_MAX - (numBytes - count)) {
         3630  +		if (interp) {
         3631  +		    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
         3632  +			    "max size for a Tcl value (%d bytes) exceeded",
         3633  +			    INT_MAX));
         3634  +		    Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
         3635  +		}
         3636  +		return NULL;
         3637  +	    }
         3638  +	    result = Tcl_NewByteArrayObj(NULL, numBytes - count + newBytes);
         3639  +								/* PANIC? */
         3640  +	    TclAppendBytesToByteArray(result, bytes, first);	
         3641  +	    TclAppendBytesToByteArray(result, iBytes, newBytes);
         3642  +	    TclAppendBytesToByteArray(result, bytes + first + count,
         3643  +		    numBytes - count - first);
         3644  +	    return result;
         3645  +	}
         3646  +
         3647  +	/* Flow through to try other approaches below */
         3648  +    }
         3649  +
         3650  +    /*
         3651  +     * TODO: Figure out how not to generate a Tcl_UniChar array rep
         3652  +     * when it can be determined objPtr->bytes points to a string of
         3653  +     * all single-byte characters so we can index it directly.
         3654  +     */
         3655  +
         3656  +    /* The traditional implementation... */
         3657  +    {
         3658  +	int numChars;
         3659  +	Tcl_UniChar *ustring = Tcl_GetUnicodeFromObj(objPtr, &numChars);
         3660  +
         3661  +	/* TODO: Is there an in-place option worth pursuing here? */
         3662  +	
         3663  +	result = Tcl_NewUnicodeObj(ustring, first);
         3664  +	if (insertPtr) {
         3665  +	    Tcl_AppendObjToObj(result, insertPtr);
         3666  +	}
         3667  +	if (first + count < numChars) {
         3668  +	    Tcl_AppendUnicodeToObj(result, ustring + first + count,
         3669  +		    numChars - first - count);
         3670  +	}
         3671  +
         3672  +	return result;
         3673  +    }
         3674  +}
  3530   3675   
  3531   3676   /*
  3532   3677    *---------------------------------------------------------------------------
  3533   3678    *
  3534   3679    * FillUnicodeRep --
  3535   3680    *
  3536   3681    *	Populate the Unicode internal rep with the Unicode form of its string

Changes to generic/tclUtil.c.

  1643   1643       return (char) ch;
  1644   1644   }
  1645   1645   #endif /* !TCL_NO_DEPRECATED */
  1646   1646   
  1647   1647   /*
  1648   1648    *----------------------------------------------------------------------
  1649   1649    *
         1650  + * UtfWellFormedEnd --
         1651  + *	Checks the end of utf string is malformed, if yes - wraps bytes
         1652  + *	to the given buffer (as well-formed NTS string).  The buffer
         1653  + *	argument should be initialized by the caller and ready to use.
         1654  + *
         1655  + * Results:
         1656  + *	The bytes with well-formed end of the string.
         1657  + *
         1658  + * Side effects:
         1659  + *	Buffer (DString) may be allocated, so must be released.
         1660  + *
         1661  + *----------------------------------------------------------------------
         1662  + */
         1663  +
         1664  +static inline const char*
         1665  +UtfWellFormedEnd(
         1666  +    Tcl_DString *buffer,	/* Buffer used to hold well-formed string. */
         1667  +    const char *bytes,		/* Pointer to the beginning of the string. */
         1668  +    int length)			/* Length of the string. */
         1669  +{
         1670  +    const char *l = bytes + length;
         1671  +    const char *p = Tcl_UtfPrev(l, bytes);
         1672  +
         1673  +    if (Tcl_UtfCharComplete(p, l - p)) {
         1674  +	return bytes;
         1675  +    }
         1676  +    /* 
         1677  +     * Malformed utf-8 end, be sure we've NTS to safe compare of end-character,
         1678  +     * avoid segfault by access violation out of range.
         1679  +     */
         1680  +    Tcl_DStringAppend(buffer, bytes, length);
         1681  +    return Tcl_DStringValue(buffer);
         1682  +}
         1683  +/*
         1684  + *----------------------------------------------------------------------
         1685  + *
  1650   1686    * TclTrimRight --
  1651         - *
  1652         - *	Takes two counted strings in the Tcl encoding which must both be null
  1653         - *	terminated. Conceptually trims from the right side of the first string
  1654         - *	all characters found in the second string.
         1687  + *	Takes two counted strings in the Tcl encoding.  Conceptually
         1688  + *	finds the sub string (offset) to trim from the right side of the
         1689  + *	first string all characters found in the second string.
  1655   1690    *
  1656   1691    * Results:
  1657   1692    *	The number of bytes to be removed from the end of the string.
  1658   1693    *
  1659   1694    * Side effects:
  1660   1695    *	None.
  1661   1696    *
  1662   1697    *----------------------------------------------------------------------
  1663   1698    */
  1664   1699   
  1665         -int
  1666         -TclTrimRight(
         1700  +static inline int
         1701  +TrimRight(
  1667   1702       const char *bytes,		/* String to be trimmed... */
  1668   1703       int numBytes,		/* ...and its length in bytes */
  1669   1704       const char *trim,		/* String of trim characters... */
  1670   1705       int numTrim)		/* ...and its length in bytes */
  1671   1706   {
  1672   1707       const char *p = bytes + numBytes;
  1673   1708       int pInc;
  1674   1709       Tcl_UniChar ch1 = 0, ch2 = 0;
  1675   1710   
  1676         -    if ((bytes[numBytes] != '\0') || (trim[numTrim] != '\0')) {
  1677         -	Tcl_Panic("TclTrimRight works only on null-terminated strings");
  1678         -    }
  1679         -
  1680         -    /*
  1681         -     * Empty strings -> nothing to do.
  1682         -     */
  1683         -
  1684         -    if ((numBytes == 0) || (numTrim == 0)) {
  1685         -	return 0;
  1686         -    }
  1687         -
  1688   1711       /*
  1689   1712        * Outer loop: iterate over string to be trimmed.
  1690   1713        */
  1691   1714   
  1692   1715       do {
  1693   1716   	const char *q = trim;
  1694   1717   	int bytesLeft = numTrim;
................................................................................
  1719   1742   	    p += pInc;
  1720   1743   	    break;
  1721   1744   	}
  1722   1745       } while (p > bytes);
  1723   1746   
  1724   1747       return numBytes - (p - bytes);
  1725   1748   }
         1749  +
         1750  +int
         1751  +TclTrimRight(
         1752  +    const char *bytes,	/* String to be trimmed... */
         1753  +    int numBytes,	/* ...and its length in bytes */
         1754  +    const char *trim,	/* String of trim characters... */
         1755  +    int numTrim)	/* ...and its length in bytes */
         1756  +{
         1757  +    int res;
         1758  +    Tcl_DString bytesBuf, trimBuf;
         1759  +
         1760  +    /* Empty strings -> nothing to do */
         1761  +    if ((numBytes == 0) || (numTrim == 0)) {
         1762  +	return 0;
         1763  +    }
         1764  +
         1765  +    Tcl_DStringInit(&bytesBuf);
         1766  +    Tcl_DStringInit(&trimBuf);
         1767  +    bytes = UtfWellFormedEnd(&bytesBuf, bytes, numBytes);
         1768  +    trim = UtfWellFormedEnd(&trimBuf, trim, numTrim);
         1769  +
         1770  +    res = TrimRight(bytes, numBytes, trim, numTrim);
         1771  +    if (res > numBytes) {
         1772  +	res = numBytes;
         1773  +    }
         1774  +
         1775  +    Tcl_DStringFree(&bytesBuf);
         1776  +    Tcl_DStringFree(&trimBuf);
         1777  +
         1778  +    return res;
         1779  +}
  1726   1780   
  1727   1781   /*
  1728   1782    *----------------------------------------------------------------------
  1729   1783    *
  1730   1784    * TclTrimLeft --
  1731   1785    *
  1732         - *	Takes two counted strings in the Tcl encoding which must both be null
  1733         - *	terminated. Conceptually trims from the left side of the first string
  1734         - *	all characters found in the second string.
         1786  + *	Takes two counted strings in the Tcl encoding.  Conceptually
         1787  + *	finds the sub string (offset) to trim from the left side of the
         1788  + *	first string all characters found in the second string.
  1735   1789    *
  1736   1790    * Results:
  1737   1791    *	The number of bytes to be removed from the start of the string.
  1738   1792    *
  1739   1793    * Side effects:
  1740   1794    *	None.
  1741   1795    *
  1742   1796    *----------------------------------------------------------------------
  1743   1797    */
  1744   1798   
  1745         -int
  1746         -TclTrimLeft(
         1799  +static inline int
         1800  +TrimLeft(
  1747   1801       const char *bytes,		/* String to be trimmed... */
  1748   1802       int numBytes,		/* ...and its length in bytes */
  1749   1803       const char *trim,		/* String of trim characters... */
  1750   1804       int numTrim)		/* ...and its length in bytes */
  1751   1805   {
  1752   1806       const char *p = bytes;
  1753   1807   	Tcl_UniChar ch1 = 0, ch2 = 0;
  1754   1808   
  1755         -    if ((bytes[numBytes] != '\0') || (trim[numTrim] != '\0')) {
  1756         -	Tcl_Panic("TclTrimLeft works only on null-terminated strings");
  1757         -    }
  1758         -
  1759         -    /*
  1760         -     * Empty strings -> nothing to do.
  1761         -     */
  1762         -
  1763         -    if ((numBytes == 0) || (numTrim == 0)) {
  1764         -	return 0;
  1765         -    }
  1766         -
  1767   1809       /*
  1768   1810        * Outer loop: iterate over string to be trimmed.
  1769   1811        */
  1770   1812   
  1771   1813       do {
  1772   1814   	int pInc = TclUtfToUniChar(p, &ch1);
  1773   1815   	const char *q = trim;
................................................................................
  1794   1836   	     */
  1795   1837   
  1796   1838   	    break;
  1797   1839   	}
  1798   1840   
  1799   1841   	p += pInc;
  1800   1842   	numBytes -= pInc;
  1801         -    } while (numBytes);
         1843  +    } while (numBytes > 0);
  1802   1844   
  1803   1845       return p - bytes;
  1804   1846   }
         1847  +
         1848  +int
         1849  +TclTrimLeft(
         1850  +    const char *bytes,	/* String to be trimmed... */
         1851  +    int numBytes,	/* ...and its length in bytes */
         1852  +    const char *trim,	/* String of trim characters... */
         1853  +    int numTrim)	/* ...and its length in bytes */
         1854  +{
         1855  +    int res;
         1856  +    Tcl_DString bytesBuf, trimBuf;
         1857  +
         1858  +    /* Empty strings -> nothing to do */
         1859  +    if ((numBytes == 0) || (numTrim == 0)) {
         1860  +	return 0;
         1861  +    }
         1862  +
         1863  +    Tcl_DStringInit(&bytesBuf);
         1864  +    Tcl_DStringInit(&trimBuf);
         1865  +    bytes = UtfWellFormedEnd(&bytesBuf, bytes, numBytes);
         1866  +    trim = UtfWellFormedEnd(&trimBuf, trim, numTrim);
         1867  +
         1868  +    res = TrimLeft(bytes, numBytes, trim, numTrim);
         1869  +    if (res > numBytes) {
         1870  +	res = numBytes;
         1871  +    }
         1872  +
         1873  +    Tcl_DStringFree(&bytesBuf);
         1874  +    Tcl_DStringFree(&trimBuf);
         1875  +
         1876  +    return res;
         1877  +}
         1878  +
         1879  +/*
         1880  + *----------------------------------------------------------------------
         1881  + *
         1882  + * TclTrim --
         1883  + *	Finds the sub string (offset) to trim from both sides of the
         1884  + *	first string all characters found in the second string.
         1885  + *
         1886  + * Results:
         1887  + *	The number of bytes to be removed from the start of the string
         1888  + *
         1889  + * Side effects:
         1890  + *	None.
         1891  + *
         1892  + *----------------------------------------------------------------------
         1893  + */
         1894  +
         1895  +int
         1896  +TclTrim(
         1897  +    const char *bytes,	/* String to be trimmed... */
         1898  +    int numBytes,	/* ...and its length in bytes */
         1899  +    const char *trim,	/* String of trim characters... */
         1900  +    int numTrim,	/* ...and its length in bytes */
         1901  +    int *trimRight)		/* Offset from the end of the string. */
         1902  +{
         1903  +    int trimLeft;
         1904  +    Tcl_DString bytesBuf, trimBuf;
         1905  +
         1906  +    *trimRight = 0;
         1907  +    /* Empty strings -> nothing to do */
         1908  +    if ((numBytes == 0) || (numTrim == 0)) {
         1909  +	return 0;
         1910  +    }
         1911  +
         1912  +    Tcl_DStringInit(&bytesBuf);
         1913  +    Tcl_DStringInit(&trimBuf);
         1914  +    bytes = UtfWellFormedEnd(&bytesBuf, bytes, numBytes);
         1915  +    trim = UtfWellFormedEnd(&trimBuf, trim, numTrim);
         1916  +
         1917  +    trimLeft = TrimLeft(bytes, numBytes, trim, numTrim);
         1918  +    if (trimLeft > numBytes) {
         1919  +	trimLeft = numBytes;
         1920  +    }
         1921  +    numBytes -= trimLeft;
         1922  +    /* have to trim yet (first char was already verified within TrimLeft) */
         1923  +    if (numBytes > 1) {
         1924  +	bytes += trimLeft;
         1925  +	*trimRight = TrimRight(bytes, numBytes, trim, numTrim);
         1926  +	if (*trimRight > numBytes) {
         1927  +	    *trimRight = numBytes;
         1928  +	}
         1929  +    }
         1930  +
         1931  +    Tcl_DStringFree(&bytesBuf);
         1932  +    Tcl_DStringFree(&trimBuf);
         1933  +
         1934  +    return trimLeft;
         1935  +}
  1805   1936   
  1806   1937   /*
  1807   1938    *----------------------------------------------------------------------
  1808   1939    *
  1809   1940    * Tcl_Concat --
  1810   1941    *
  1811   1942    *	Concatenate a set of strings into a single large string.
................................................................................
  1865   1996       /*
  1866   1997        * All element bytes + (argc - 1) spaces + 1 terminating NULL.
  1867   1998        */
  1868   1999   
  1869   2000       result = ckalloc((unsigned) (bytesNeeded + argc));
  1870   2001   
  1871   2002       for (p = result, i = 0;  i < argc;  i++) {
  1872         -	int trim, elemLength;
         2003  +	int triml, trimr, elemLength;
  1873   2004   	const char *element;
  1874   2005   
  1875   2006   	element = argv[i];
  1876   2007   	elemLength = strlen(argv[i]);
  1877   2008   
  1878         -	/*
  1879         -	 * Trim away the leading whitespace.
  1880         -	 */
         2009  +	/* Trim away the leading/trailing whitespace. */
         2010  +	triml = TclTrim(element, elemLength, CONCAT_TRIM_SET,
         2011  +		CONCAT_WS_SIZE, &trimr);
         2012  +	element += triml;
         2013  +	elemLength -= triml + trimr;
  1881   2014   
  1882         -	trim = TclTrimLeft(element, elemLength, CONCAT_TRIM_SET,
  1883         -		CONCAT_WS_SIZE);
  1884         -	element += trim;
  1885         -	elemLength -= trim;
  1886         -
  1887         -	/*
  1888         -	 * Trim away the trailing whitespace. Do not permit trimming to expose
  1889         -	 * a final backslash character.
  1890         -	 */
  1891         -
  1892         -	trim = TclTrimRight(element, elemLength, CONCAT_TRIM_SET,
  1893         -		CONCAT_WS_SIZE);
  1894         -	trim -= trim && (element[elemLength - trim - 1] == '\\');
  1895         -	elemLength -= trim;
         2015  +	/* Do not permit trimming to expose a final backslash character. */
         2016  +	elemLength += trimr && (element[elemLength - 1] == '\\');
  1896   2017   
  1897   2018   	/*
  1898   2019   	 * If we're left with empty element after trimming, do nothing.
  1899   2020   	 */
  1900   2021   
  1901   2022   	if (elemLength == 0) {
  1902   2023   	    continue;
................................................................................
  2008   2129        */
  2009   2130   
  2010   2131       TclNewObj(resPtr);
  2011   2132       (void) Tcl_AttemptSetObjLength(resPtr, bytesNeeded + objc - 1);
  2012   2133       Tcl_SetObjLength(resPtr, 0);
  2013   2134   
  2014   2135       for (i = 0;  i < objc;  i++) {
  2015         -	int trim;
         2136  +	int triml, trimr;
  2016   2137   
  2017   2138   	element = TclGetStringFromObj(objv[i], &elemLength);
  2018   2139   
  2019         -	/*
  2020         -	 * Trim away the leading whitespace.
  2021         -	 */
         2140  +	/* Trim away the leading/trailing whitespace. */
         2141  +	triml = TclTrim(element, elemLength, CONCAT_TRIM_SET,
         2142  +		CONCAT_WS_SIZE, &trimr);
         2143  +	element += triml;
         2144  +	elemLength -= triml + trimr;
  2022   2145   
  2023         -	trim = TclTrimLeft(element, elemLength, CONCAT_TRIM_SET,
  2024         -		CONCAT_WS_SIZE);
  2025         -	element += trim;
  2026         -	elemLength -= trim;
  2027         -
  2028         -	/*
  2029         -	 * Trim away the trailing whitespace. Do not permit trimming to expose
  2030         -	 * a final backslash character.
  2031         -	 */
  2032         -
  2033         -	trim = TclTrimRight(element, elemLength, CONCAT_TRIM_SET,
  2034         -		CONCAT_WS_SIZE);
  2035         -	trim -= trim && (element[elemLength - trim - 1] == '\\');
  2036         -	elemLength -= trim;
         2146  +	/* Do not permit trimming to expose a final backslash character. */
         2147  +	elemLength += trimr && (element[elemLength - 1] == '\\');
  2037   2148   
  2038   2149   	/*
  2039   2150   	 * If we're left with empty element after trimming, do nothing.
  2040   2151   	 */
  2041   2152   
  2042   2153   	if (elemLength == 0) {
  2043   2154   	    continue;

Changes to library/msgcat/msgcat.tcl.

     1      1   # msgcat.tcl --
     2      2   #
     3      3   #	This file defines various procedures which implement a
     4      4   #	message catalog facility for Tcl programs.  It should be
     5      5   #	loaded with the command "package require msgcat".
     6      6   #
     7         -# Copyright (c) 2010-2015 by Harald Oehlmann.
            7  +# Copyright (c) 2010-2018 by Harald Oehlmann.
     8      8   # Copyright (c) 1998-2000 by Ajuba Solutions.
     9      9   # Copyright (c) 1998 by Mark Harrison.
    10     10   #
    11     11   # See the file "license.terms" for information on usage and redistribution
    12     12   # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
    13     13   
    14         -package require Tcl 8.5-
           14  +# We use oo::define::self, which is new in Tcl 8.7
           15  +package require Tcl 8.7-
    15     16   # When the version number changes, be sure to update the pkgIndex.tcl file,
    16     17   # and the installation directory in the Makefiles.
    17         -package provide msgcat 1.6.1
           18  +package provide msgcat 1.7.0
    18     19   
    19     20   namespace eval msgcat {
    20         -    namespace export mc mcexists mcload mclocale mcmax mcmset mcpreferences mcset\
           21  +    namespace export mc mcn mcexists mcload mclocale mcmax\
           22  +	    mcmset mcpreferences mcset\
    21     23               mcunknown mcflset mcflmset mcloadedlocales mcforgetpackage\
    22         -	    mcpackageconfig mcpackagelocale
           24  +	    mcpackagenamespaceget mcpackageconfig mcpackagelocale mcutil
    23     25   
    24     26       # Records the list of locales to search
    25     27       variable Loclist {}
    26     28   
    27     29       # List of currently loaded locales
    28     30       variable LoadedLocales {}
    29     31   
................................................................................
    37     39   	    unknowncmd {} loadedlocales {} loclist {}]
    38     40   
    39     41       # Records the mapping between source strings and translated strings.  The
    40     42       # dict key is of the form "<namespace> <locale> <src>", where locale and
    41     43       # namespace should be themselves dict values and the value is
    42     44       # the translated string.
    43     45       variable Msgs [dict create]
           46  +}
    44     47   
           48  +# create ensemble namespace for mcutil command
           49  +namespace eval msgcat::mcutil {
           50  +    namespace export getsystemlocale getpreferences
           51  +    namespace ensemble create -prefix 0
           52  +    
    45     53       # Map of language codes used in Windows registry to those of ISO-639
    46     54       if {[info sharedlibextension] eq ".dll"} {
    47     55   	variable WinRegToISO639 [dict create  {*}{
    48     56   	    01 ar 0401 ar_SA 0801 ar_IQ 0c01 ar_EG 1001 ar_LY 1401 ar_DZ
    49     57   		  1801 ar_MA 1c01 ar_TN 2001 ar_OM 2401 ar_YE 2801 ar_SY
    50     58   		  2c01 ar_JO 3001 ar_LB 3401 ar_KW 3801 ar_AE 3c01 ar_BH
    51     59   		  4001 ar_QA
................................................................................
   188    196   #	src	The string to translate.
   189    197   #	args	Args to pass to the format command
   190    198   #
   191    199   # Results:
   192    200   #	Returns the translated string.  Propagates errors thrown by the
   193    201   #	format command.
   194    202   
   195         -proc msgcat::mc {src args} {
   196         -    # this may be replaced by:
   197         -    # return [mcget -namespace [uplevel 1 [list ::namespace current]] --\
   198         -    #	    $src {*}$args]
          203  +proc msgcat::mc {args} {
          204  +    tailcall mcn [PackageNamespaceGet] {*}$args
          205  +}
          206  +
          207  +# msgcat::mcn --
          208  +#
          209  +#	Find the translation for the given string based on the current
          210  +#	locale setting. Check the passed namespace first, then look in each
          211  +#	parent namespace until the source is found.  If additional args are
          212  +#	specified, use the format command to work them into the traslated
          213  +#	string.
          214  +#	If no catalog item is found, mcunknown is called in the caller frame
          215  +#	and its result is returned.
          216  +#
          217  +# Arguments:
          218  +#	ns	Package namespace of the translation
          219  +#	src	The string to translate.
          220  +#	args	Args to pass to the format command
          221  +#
          222  +# Results:
          223  +#	Returns the translated string.  Propagates errors thrown by the
          224  +#	format command.
          225  +
          226  +proc msgcat::mcn {ns src args} {
   199    227   
   200    228       # Check for the src in each namespace starting from the local and
   201    229       # ending in the global.
   202    230   
   203    231       variable Msgs
   204    232       variable Loclist
   205    233   
   206         -    set ns [uplevel 1 [list ::namespace current]]
   207    234       set loclist [PackagePreferences $ns]
   208    235   
   209    236       set nscur $ns
   210    237       while {$nscur != ""} {
   211    238   	foreach loc $loclist {
   212    239   	    if {[dict exists $Msgs $nscur $loc $src]} {
   213    240   		return [DefaultUnknown "" [dict get $Msgs $nscur $loc $src]\
................................................................................
   215    242   	    }
   216    243   	}
   217    244   	set nscur [namespace parent $nscur]
   218    245       }
   219    246       # call package local or default unknown command
   220    247       set args [linsert $args 0 [lindex $loclist 0] $src]
   221    248       switch -exact -- [Invoke unknowncmd $args $ns result 1] {
   222         -	0 { return [uplevel 1 [linsert $args 0 [namespace origin mcunknown]]] }
          249  +	0 { tailcall mcunknown {*}$args }
   223    250   	1 { return [DefaultUnknown {*}$args] }
   224    251   	default { return $result }
   225    252       }
   226    253   }
   227    254   
   228    255   # msgcat::mcexists --
   229    256   #
................................................................................
   241    268   
   242    269   proc msgcat::mcexists {args} {
   243    270   
   244    271       variable Msgs
   245    272       variable Loclist
   246    273       variable PackageConfig
   247    274   
   248         -    set ns [uplevel 1 [list ::namespace current]]
   249         -    set loclist [PackagePreferences $ns]
   250         -
   251    275       while {[llength $args] != 1} {
   252    276   	set args [lassign $args option]
   253    277   	switch -glob -- $option {
   254         -	    -exactnamespace { set exactnamespace 1 }
   255         -	    -exactlocale { set loclist [lrange $loclist 0 0] }
          278  +	    -exactnamespace - -exactlocale { set $option 1 }
          279  +	    -namespace {
          280  +		if {[llength $args] < 2} {
          281  +		    return -code error\
          282  +			    "Argument missing for switch \"-namespace\""
          283  +		}
          284  +		set args [lassign $args ns]
          285  +	    }
   256    286   	    -* { return -code error "unknown option \"$option\"" }
   257    287   	    default {
   258    288   		return -code error "wrong # args: should be\
   259    289   			\"[lindex [info level 0] 0] ?-exactnamespace?\
   260         -			?-exactlocale? src\""
          290  +			?-exactlocale? ?-namespace ns? src\""
   261    291   	    }
   262    292   	}
   263    293       }
   264    294       set src [lindex $args 0]
          295  +    
          296  +    if {![info exists ns]} { set ns [PackageNamespaceGet] }
          297  +
          298  +    set loclist [PackagePreferences $ns]
          299  +    if {[info exists -exactlocale]} { set loclist [lrange $loclist 0 0] }
   265    300   
   266    301       while {$ns ne ""} {
   267    302   	foreach loc $loclist {
   268    303   	    if {[dict exists $Msgs $ns $loc $src]} {
   269    304   		return 1
   270    305   	    }
   271    306   	}
   272         -	if {[info exists exactnamespace]} {return 0}
          307  +	if {[info exists -exactnamespace]} {return 0}
   273    308   	set ns [namespace parent $ns]
   274    309       }
   275    310       return 0
   276    311   }
   277    312   
   278    313   # msgcat::mclocale --
   279    314   #
................................................................................
   299    334   
   300    335       if {$len == 1} {
   301    336   	set newLocale [string tolower [lindex $args 0]]
   302    337   	if {$newLocale ne [file tail $newLocale]} {
   303    338   	    return -code error "invalid newLocale value \"$newLocale\":\
   304    339   		    could be path to unsafe code."
   305    340   	}
   306         -	if {[lindex $Loclist 0] ne $newLocale} {
   307         -	    set Loclist [GetPreferences $newLocale]
   308         -
   309         -	    # locale not loaded jet
   310         -	    LoadAll $Loclist
   311         -	    # Invoke callback
   312         -	    Invoke changecmd $Loclist
   313         -	}
          341  +	mcpreferences {*}[mcutil getpreferences $newLocale]
   314    342       }
   315    343       return [lindex $Loclist 0]
   316    344   }
   317    345   
   318         -# msgcat::GetPreferences --
          346  +# msgcat::mcutil::getpreferences --
   319    347   #
   320    348   #	Get list of locales from a locale.
   321    349   #	The first element is always the lowercase locale.
   322    350   #	Other elements have one component separated by "_" less.
   323    351   #	Multiple "_" are seen as one separator: de__ch_spec de__ch de {}
          352  +#
          353  +#	This method is part of the ensemble mcutil
   324    354   #
   325    355   # Arguments:
   326    356   #	Locale.
   327    357   #
   328    358   # Results:
   329    359   #	Locale list
   330    360   
   331         -proc msgcat::GetPreferences {locale} {
          361  +proc msgcat::mcutil::getpreferences {locale} {
   332    362       set locale [string tolower $locale]
   333    363       set loclist [list $locale]
   334    364       while {-1 !=[set pos [string last "_" $locale]]} {
   335    365   	set locale [string range $locale 0 $pos-1]
   336    366   	if { "_" ne [string index $locale end] } {
   337    367   	    lappend loclist $locale
   338    368   	}
................................................................................
   345    375   
   346    376   # msgcat::mcpreferences --
   347    377   #
   348    378   #	Fetch the list of locales used to look up strings, ordered from
   349    379   #	most preferred to least preferred.
   350    380   #
   351    381   # Arguments:
   352         -#	None.
          382  +#	New location list
   353    383   #
   354    384   # Results:
   355    385   #	Returns an ordered list of the locales preferred by the user.
   356    386   
   357         -proc msgcat::mcpreferences {} {
          387  +proc msgcat::mcpreferences {args} {
   358    388       variable Loclist
          389  +
          390  +    if {[llength $args] > 0} {
          391  +	# args is the new loclist
          392  +	if {![ListEqualString $args $Loclist]} {
          393  +	    set Loclist $args
          394  +
          395  +	    # locale not loaded jet
          396  +	    LoadAll $Loclist
          397  +	    # Invoke callback
          398  +	    Invoke changecmd $Loclist
          399  +	}
          400  +    }
   359    401       return $Loclist
   360    402   }
          403  +
          404  +# msgcat::ListStringEqual --
          405  +#
          406  +#	Compare two strings for equal string contents
          407  +#
          408  +# Arguments:
          409  +#	list1		first list
          410  +#	list2		second list
          411  +#
          412  +# Results:
          413  +#	1 if lists of strings are identical, 0 otherwise
          414  +
          415  +proc msgcat::ListEqualString {list1 list2} {
          416  +    if {[llength $list1] != [llength $list2]} {
          417  +	return 0
          418  +    }
          419  +    foreach item1 $list1 item2 $list2 {
          420  +	if {$item1 ne $item2} {
          421  +	    return 0
          422  +	}
          423  +    }
          424  +    return 1
          425  +}
   361    426   
   362    427   # msgcat::mcloadedlocales --
   363    428   #
   364    429   #	Get or change the list of currently loaded default locales
   365    430   #
   366    431   #	The following subcommands are available:
   367    432   #	loaded
................................................................................
   438    503   # Arguments:
   439    504   #	subcommand		see list above
   440    505   #	locale			package locale (only set subcommand)
   441    506   #
   442    507   # Results:
   443    508   #	Empty string, if not stated differently for the subcommand
   444    509   
   445         -proc msgcat::mcpackagelocale {subcommand {locale ""}} {
          510  +proc msgcat::mcpackagelocale {subcommand args} {
   446    511       # todo: implement using an ensemble
   447    512       variable Loclist
   448    513       variable LoadedLocales
   449    514       variable Msgs
   450    515       variable PackageConfig
   451    516       # Check option
   452    517       # check if required item is exactly provided
   453         -    if {[llength [info level 0]] == 2} {
   454         -	# locale not given
   455         -	unset locale
   456         -    } else {
   457         -	# locale given
   458         -	if {$subcommand in
   459         -		{"get" "isset" "unset" "preferences" "loaded" "clear"} } {
   460         -	    return -code error "wrong # args: should be\
   461         -		    \"[lrange [info level 0] 0 1]\""
   462         -	}
   463         -        set locale [string tolower $locale]
          518  +    if {    [llength $args] > 0
          519  +	    && $subcommand in {"get" "isset" "unset" "loaded" "clear"} } {
          520  +	return -code error "wrong # args: should be\
          521  +		\"[lrange [info level 0] 0 1]\""
   464    522       }
   465         -    set ns [uplevel 1 {::namespace current}]
          523  +    set ns [PackageNamespaceGet]
   466    524   
   467    525       switch -exact -- $subcommand {
   468    526   	get { return [lindex [PackagePreferences $ns] 0] }
   469         -	preferences { return [PackagePreferences $ns] }
   470    527   	loaded { return [PackageLocales $ns] }
   471         -	present { return [expr {$locale in [PackageLocales $ns]} ]}
          528  +	present {
          529  +	    if {[llength $args] != 1} {
          530  +		return -code error "wrong # args: should be\
          531  +			\"[lrange [info level 0] 0 1] locale\""
          532  +	    }
          533  +	    return [expr {[string tolower [lindex $args 0]]
          534  +		    in [PackageLocales $ns]} ]
          535  +	}
   472    536   	isset { return [dict exists $PackageConfig loclist $ns] }
   473         -	set { # set a package locale or add a package locale
          537  +	set - preferences {
          538  +	    # set a package locale or add a package locale
          539  +	    set fSet [expr {$subcommand eq "set"}]
          540  +	    
          541  +	    # Check parameter
          542  +	    if {$fSet && 1 < [llength $args] } {
          543  +		return -code error "wrong # args: should be\
          544  +			\"[lrange [info level 0] 0 1] ?locale?\""
          545  +	    }
          546  +
          547  +	    # > Return preferences if no parameter
          548  +	    if {!$fSet && 0 == [llength $args] } {
          549  +		return [PackagePreferences $ns]
          550  +	    }
   474    551   
   475    552   	    # Copy the default locale if no package locale set so far
   476    553   	    if {![dict exists $PackageConfig loclist $ns]} {
   477    554   		dict set PackageConfig loclist $ns $Loclist
   478    555   		dict set PackageConfig loadedlocales $ns $LoadedLocales
   479    556   	    }
   480    557   
   481         -	    # Check if changed
   482         -	    set loclist [dict get $PackageConfig loclist $ns]
   483         -	    if {! [info exists locale] || $locale eq [lindex $loclist 0] } {
   484         -		return [lindex $loclist 0]
          558  +	    # No argument for set: return current package locale
          559  +	    # The difference to no argument and subcommand "preferences" is,
          560  +	    # that "preferences" does not set the package locale property.
          561  +	    # This case is processed above, so no check for fSet here
          562  +	    if { 0 == [llength $args] } {
          563  +		return [lindex [dict get $PackageConfig loclist $ns] 0]
          564  +	    }
          565  +
          566  +	    # Get new loclist
          567  +	    if {$fSet} {
          568  +		set loclist [mcutil getpreferences [lindex $args 0]]
          569  +	    } else {
          570  +		set loclist $args
          571  +	    }
          572  +
          573  +	    # Check if not changed to return imediately
          574  +	    if {    [ListEqualString $loclist\
          575  +			[dict get $PackageConfig loclist $ns]] } {
          576  +		if {$fSet} {
          577  +		    return [lindex $loclist 0]
          578  +		}
          579  +		return $loclist
   485    580   	    }
   486    581   
   487    582   	    # Change loclist
   488         -	    set loclist [GetPreferences $locale]
   489         -	    set locale [lindex $loclist 0]
   490    583   	    dict set PackageConfig loclist $ns $loclist
   491    584   
   492    585   	    # load eventual missing locales
   493    586   	    set loadedLocales [dict get $PackageConfig loadedlocales $ns]
   494         -	    if {$locale in $loadedLocales} { return $locale }
   495    587   	    set loadLocales [ListComplement $loadedLocales $loclist]
   496    588   	    dict set PackageConfig loadedlocales $ns\
   497    589   		    [concat $loadedLocales $loadLocales]
   498    590   	    Load $ns $loadLocales
   499         -	    return $locale
          591  +	    if {$fSet} {
          592  +		return [lindex $loclist 0]
          593  +	    }
          594  +	    return $loclist
   500    595   	}
   501    596   	clear { # Remove all locales not contained in Loclist
   502    597   	    if {![dict exists $PackageConfig loclist $ns]} {
   503    598   		return -code error "clear only when package locale set"
   504    599   	    }
   505    600   	    set loclist [dict get $PackageConfig loclist $ns]
   506    601   	    dict set PackageConfig loadedlocales $ns $loclist
................................................................................
   547    642   #	Remove any data of the calling package from msgcat
   548    643   #
   549    644   
   550    645   proc msgcat::mcforgetpackage {} {
   551    646       # todo: this may be implemented using an ensemble
   552    647       variable PackageConfig
   553    648       variable Msgs
   554         -    set ns [uplevel 1 {::namespace current}]
          649  +    set ns [PackageNamespaceGet]
   555    650       # Remove MC items
   556    651       dict unset Msgs $ns
   557    652       # Remove config items
   558    653       foreach key [dict keys $PackageConfig] {
   559    654   	dict unset PackageConfig $key $ns
   560    655       }
   561    656       return
   562    657   }
          658  +
          659  +# msgcat::mcgetmynamespace --
          660  +#
          661  +#	Return the package namespace of the caller
          662  +#	This consideres to be called from a class or object.
          663  +
          664  +proc msgcat::mcpackagenamespaceget {} {
          665  +    return [PackageNamespaceGet]
          666  +}
   563    667   
   564    668   # msgcat::mcpackageconfig --
   565    669   #
   566    670   #	Get or modify the per caller namespace (e.g. packages) config options.
   567    671   #
   568    672   #	Available subcommands are:
   569    673   #
................................................................................
   612    716   #
   613    717   # Results:
   614    718   #	Depends on the subcommand and option and is described there
   615    719   
   616    720   proc msgcat::mcpackageconfig {subcommand option {value ""}} {
   617    721       variable PackageConfig
   618    722       # get namespace
   619         -    set ns [uplevel 1 {::namespace current}]
          723  +    set ns [PackageNamespaceGet]
   620    724   
   621    725       if {$option ni {"mcfolder" "loadcmd" "changecmd" "unknowncmd"}} {
   622    726   	return -code error "bad option \"$option\": must be mcfolder, loadcmd,\
   623    727   		changecmd, or unknowncmd"
   624    728       }
   625    729   
   626    730       # check if value argument is exactly provided
................................................................................
   752    856   # Arguments:
   753    857   #	langdir		The directory to search.
   754    858   #
   755    859   # Results:
   756    860   #	Returns the number of message catalogs that were loaded.
   757    861   
   758    862   proc msgcat::mcload {langdir} {
   759         -    return [uplevel 1 [list\
   760         -	    [namespace origin mcpackageconfig] set mcfolder $langdir]]
          863  +    tailcall mcpackageconfig set mcfolder $langdir
   761    864   }
   762    865   
   763    866   # msgcat::LoadAll --
   764    867   #
   765    868   #	Load a list of locales for all packages not having a package locale
   766    869   #	list.
   767    870   #
................................................................................
   919   1022   
   920   1023   proc msgcat::mcset {locale src {dest ""}} {
   921   1024       variable Msgs
   922   1025       if {[llength [info level 0]] == 3} { ;# dest not specified
   923   1026   	set dest $src
   924   1027       }
   925   1028   
   926         -    set ns [uplevel 1 [list ::namespace current]]
         1029  +    set ns [PackageNamespaceGet]
   927   1030   
   928   1031       set locale [string tolower $locale]
   929   1032   
   930   1033       dict set Msgs $ns $locale $src $dest
   931   1034       return $dest
   932   1035   }
   933   1036   
................................................................................
   947   1050       variable FileLocale
   948   1051       variable Msgs
   949   1052   
   950   1053       if {![info exists FileLocale]} {
   951   1054   	return -code error "must only be used inside a message catalog loaded\
   952   1055   		with ::msgcat::mcload"
   953   1056       }
   954         -    return [uplevel 1 [list [namespace origin mcset] $FileLocale $src $dest]]
         1057  +    tailcall mcset $FileLocale $src $dest
   955   1058   }
   956   1059   
   957   1060   # msgcat::mcmset --
   958   1061   #
   959   1062   #	Set the translation for multiple strings in a specified locale.
   960   1063   #
   961   1064   # Arguments:
................................................................................
   971   1074       set length [llength $pairs]
   972   1075       if {$length % 2} {
   973   1076   	return -code error "bad translation list:\
   974   1077   		should be \"[lindex [info level 0] 0] locale {src dest ...}\""
   975   1078       }
   976   1079   
   977   1080       set locale [string tolower $locale]
   978         -    set ns [uplevel 1 [list ::namespace current]]
         1081  +    set ns [PackageNamespaceGet]
   979   1082   
   980   1083       foreach {src dest} $pairs {
   981   1084   	dict set Msgs $ns $locale $src $dest
   982   1085       }
   983   1086   
   984   1087       return [expr {$length / 2}]
   985   1088   }
................................................................................
   998   1101       variable FileLocale
   999   1102       variable Msgs
  1000   1103   
  1001   1104       if {![info exists FileLocale]} {
  1002   1105   	return -code error "must only be used inside a message catalog loaded\
  1003   1106   		with ::msgcat::mcload"
  1004   1107       }
  1005         -    return [uplevel 1 [list [namespace origin mcmset] $FileLocale $pairs]]
         1108  +    tailcal mcmset $FileLocale $pairs
  1006   1109   }
  1007   1110   
  1008   1111   # msgcat::mcunknown --
  1009   1112   #
  1010   1113   #	This routine is called by msgcat::mc if a translation cannot
  1011   1114   #	be found for a string and no unknowncmd is set for the current
  1012   1115   #	package. This routine is intended to be replaced
................................................................................
  1020   1123   #	src		The string to be translated.
  1021   1124   #	args		Args to pass to the format command
  1022   1125   #
  1023   1126   # Results:
  1024   1127   #	Returns the translated value.
  1025   1128   
  1026   1129   proc msgcat::mcunknown {args} {
  1027         -    return [uplevel 1 [list [namespace origin DefaultUnknown] {*}$args]]
         1130  +    tailcall DefaultUnknown {*}$args
  1028   1131   }
  1029   1132   
  1030   1133   # msgcat::DefaultUnknown --
  1031   1134   #
  1032   1135   #	This routine is called by msgcat::mc if a translation cannot
  1033   1136   #	be found for a string in the following circumstances:
  1034   1137   #	- Default global handler, if mcunknown is not redefined.
................................................................................
  1063   1166   #	args	strings to translate.
  1064   1167   #
  1065   1168   # Results:
  1066   1169   #	Returns the length of the longest translated string.
  1067   1170   
  1068   1171   proc msgcat::mcmax {args} {
  1069   1172       set max 0
         1173  +    set ns [PackageNamespaceGet]
  1070   1174       foreach string $args {
  1071         -	set translated [uplevel 1 [list [namespace origin mc] $string]]
         1175  +	set translated [uplevel 1 [list [namespace origin mcn] $ns $string]]
  1072   1176   	set len [string length $translated]
  1073   1177   	if {$len>$max} {
  1074   1178   	    set max $len
  1075   1179   	}
  1076   1180       }
  1077   1181       return $max
  1078   1182   }
  1079   1183   
  1080   1184   # Convert the locale values stored in environment variables to a form
  1081   1185   # suitable for passing to [mclocale]
  1082         -proc msgcat::ConvertLocale {value} {
         1186  +proc msgcat::mcutil::ConvertLocale {value} {
  1083   1187       # Assume $value is of form: $language[_$territory][.$codeset][@modifier]
  1084   1188       # Convert to form: $language[_$territory][_$modifier]
  1085   1189       #
  1086   1190       # Comment out expanded RE version -- bugs alleged
  1087   1191       # regexp -expanded {
  1088   1192       #	^		# Match all the way to the beginning
  1089   1193       #	([^[email protected]]*)	# Match "lanugage"; ends with _, ., or @
................................................................................
  1102   1206       }
  1103   1207       if {[string length $modifier]} {
  1104   1208   	append ret _$modifier
  1105   1209       }
  1106   1210       return $ret
  1107   1211   }
  1108   1212   
         1213  +# helper function to find package namespace of stack-frame -2
         1214  +# There are 4 possibilities:
         1215  +# - called from a proc
         1216  +# - called within a class definition script
         1217  +# - called from an class defined oo object
         1218  +# - called from a classless oo object
         1219  +proc ::msgcat::PackageNamespaceGet {} {
         1220  +    uplevel 2 {
         1221  +	# Check self namespace to determine environment
         1222  +	switch -exact -- [namespace which self] {
         1223  +	    {::oo::define::self} {
         1224  +		# We are within a class definition
         1225  +		return [namespace qualifiers [self]]
         1226  +	    }
         1227  +	    {::oo::Helpers::self} {
         1228  +		# We are within an object
         1229  +		set Class [info object class [self]]
         1230  +		# Check for classless defined object
         1231  +		if {$Class eq {::oo::object}} {
         1232  +		    return [namespace qualifiers [self]]
         1233  +		}
         1234  +		# Class defined object
         1235  +		return [namespace qualifiers $Class]
         1236  +	    }
         1237  +	    default {
         1238  +		# Not in object environment
         1239  +		return [namespace current]
         1240  +	    }
         1241  +	}
         1242  +    }
         1243  +}
         1244  +  
  1109   1245   # Initialize the default locale
  1110         -proc msgcat::Init {} {
         1246  +proc msgcat::mcutil::getsystemlocale {} {
  1111   1247       global env
  1112   1248   
  1113   1249       #
  1114   1250       # set default locale, try to get from environment
  1115   1251       #
  1116   1252       foreach varName {LC_ALL LC_MESSAGES LANG} {
  1117   1253   	if {[info exists env($varName)] && ("" ne $env($varName))} {
  1118         -	    if {![catch {
  1119         -		mclocale [ConvertLocale $env($varName)]
  1120         -	    }]} {
  1121         -		return
         1254  +	    if {![catch { ConvertLocale $env($varName) } locale]} {
         1255  +		return $locale
  1122   1256   	    }
  1123   1257   	}
  1124   1258       }
  1125   1259       #
  1126   1260       # On Darwin, fallback to current CFLocale identifier if available.
  1127   1261       #
  1128   1262       if {[info exists ::tcl::mac::locale] && $::tcl::mac::locale ne ""} {
  1129         -	if {![catch {
  1130         -	    mclocale [ConvertLocale $::tcl::mac::locale]
  1131         -	}]} {
  1132         -	    return
         1263  +	if {![catch { ConvertLocale $::tcl::mac::locale } locale]} {
         1264  +	    return $locale
  1133   1265   	}
  1134   1266       }
  1135   1267       #
  1136   1268       # The rest of this routine is special processing for Windows or
  1137   1269       # Cygwin. All other platforms, get out now.
  1138   1270       #
  1139   1271       if {([info sharedlibextension] ne ".dll")
  1140   1272   	    || [catch {package require registry}]} {
  1141         -	mclocale C
  1142         -	return
         1273  +	return C
  1143   1274       }
  1144   1275       #
  1145   1276       # On Windows or Cygwin, try to set locale depending on registry
  1146   1277       # settings, or fall back on locale of "C".
  1147   1278       #
  1148   1279   
  1149   1280       # On Vista and later:
................................................................................
  1166   1297   	    if {"" ne $territory} {
  1167   1298   		append locale _ $territory
  1168   1299   	    }
  1169   1300   	    set modifierDict [dict create latn latin cyrl cyrillic]
  1170   1301   	    if {[dict exists $modifierDict $script]} {
  1171   1302   		append locale @ [dict get $modifierDict $script]
  1172   1303   	    }
  1173         -	    if {![catch {mclocale [ConvertLocale $locale]}]} {
  1174         -		return
         1304  +	    if {![catch {ConvertLocale $locale} locale]} {
         1305  +		return $locale
  1175   1306   	    }
  1176   1307   	}
  1177   1308       }
  1178   1309   
  1179   1310       # then check value locale which contains a numerical language ID
  1180   1311       if {[catch {
  1181   1312   	set locale [registry get $key "locale"]
  1182   1313       }]} {
  1183         -	mclocale C
  1184         -	return
         1314  +	return C
  1185   1315       }
  1186   1316       #
  1187   1317       # Keep trying to match against smaller and smaller suffixes
  1188   1318       # of the registry value, since the latter hexadigits appear
  1189   1319       # to determine general language and earlier hexadigits determine
  1190   1320       # more precise information, such as territory.  For example,
  1191   1321       #     0409 - English - United States
................................................................................
  1192   1322       #     0809 - English - United Kingdom
  1193   1323       # Add more translations to the WinRegToISO639 array above.
  1194   1324       #
  1195   1325       variable WinRegToISO639
  1196   1326       set locale [string tolower $locale]
  1197   1327       while {[string length $locale]} {
  1198   1328   	if {![catch {
  1199         -	    mclocale [ConvertLocale [dict get $WinRegToISO639 $locale]]
  1200         -	}]} {
  1201         -	    return
         1329  +	    ConvertLocale [dict get $WinRegToISO639 $locale]
         1330  +	} localeOut]} {
         1331  +	    return $localeOut
  1202   1332   	}
  1203   1333   	set locale [string range $locale 1 end]
  1204   1334       }
  1205   1335       #
  1206   1336       # No translation known.  Fall back on "C" locale
  1207   1337       #
  1208         -    mclocale C
         1338  +    return C
  1209   1339   }
  1210         -msgcat::Init
         1340  +msgcat::mclocale [msgcat::mcutil getsystemlocale]

Changes to library/msgcat/pkgIndex.tcl.

     1         -if {![package vsatisfies [package provide Tcl] 8.5-]} {return}
     2         -package ifneeded msgcat 1.6.1 [list source [file join $dir msgcat.tcl]]
            1  +if {![package vsatisfies [package provide Tcl] 8.7-]} {return}
            2  +package ifneeded msgcat 1.7.0 [list source [file join $dir msgcat.tcl]]

Changes to tests/coroutine.test.

   735    735       }
   736    736       proc boom {} {
   737    737   	cc ; # coro created at level 2
   738    738   	C  ; # and called at level 1
   739    739       }
   740    740       boom   ; # does not crash: the coro floor is a good insulator
   741    741       list
          742  +} -cleanup {
          743  +    rename boom {}; rename cc {}; rename c {}
   742    744   } -result {}
   743    745   
   744    746   test coroutine-8.0.0 {coro inject executed} -body {
   745    747       coroutine demo apply {{} { foreach i {1 2} yield }}
   746    748       demo
   747    749       set ::result none
   748    750       tcl::unsupported::inject demo set ::result inject-executed

Changes to tests/foreach.test.

   208    208   } {a b}
   209    209   test foreach-6.3 {break tests} {catch {break foo} msg} 1
   210    210   test foreach-6.4 {break tests} {
   211    211       catch {break foo} msg
   212    212       set msg
   213    213   } {wrong # args: should be "break"}
   214    214   # Check for bug #406709
   215         -test foreach-6.5 {break tests} {
          215  +test foreach-6.5 {break tests} -body {
   216    216       proc a {} {
   217    217   	set a 1
   218    218   	foreach b b {list [concat a; break]; incr a}
   219    219   	incr a
   220    220       }
   221    221       a
   222         -} {2}
          222  +} -cleanup {
          223  +    rename a {}
          224  +} -result {2}
   223    225   
   224    226   # Test for incorrect "double evaluation" semantics
   225    227   test foreach-7.1 {delayed substitution of body} {
   226    228       proc foo {} {
   227    229          set a 0
   228    230          foreach a [list 1 2 3] "
   229    231              set x $a

Changes to tests/ioCmd.test.

  2053   2053       lappend res [catch {interp eval $idb [list puts  $chan shoo]} msg] $msg
  2054   2054       lappend res [catch {interp eval $idb [list tell  $chan]}      msg] $msg
  2055   2055       lappend res [catch {interp eval $idb [list seek  $chan 1]}    msg] $msg
  2056   2056       lappend res [catch {interp eval $idb [list gets  $chan]}      msg] $msg
  2057   2057       lappend res [catch {interp eval $idb [list close $chan]}      msg] $msg
  2058   2058       set res
  2059   2059   
         2060  +} -cleanup {
         2061  +    interp delete $idb
  2060   2062   } -constraints {testchannel} \
  2061   2063       -result {1 {Owner lost} 1 {Owner lost} 1 {Owner lost} 1 {Owner lost} 1 {Owner lost}}
  2062   2064   
  2063   2065   test iocmd-32.1 {origin interpreter of moved channel destroyed during access} -match glob -body {
  2064   2066   
  2065   2067       set ida [interp create];#puts <<$ida>>
  2066   2068       set idb [interp create];#puts <<$idb>>
................................................................................
  2095   2097   	# wait a bit, give the main thread the time to start its event
  2096   2098   	# loop to wait for the response from B
  2097   2099   	after 2000
  2098   2100   	catch { puts $chan shoo } res
  2099   2101   	set res
  2100   2102       }]
  2101   2103       set res
         2104  +} -cleanup {
         2105  +    interp delete $idb
  2102   2106   } -constraints {testchannel} -result {Owner lost}
  2103   2107   
  2104   2108   test iocmd-32.2 {delete interp of reflected chan} {
  2105   2109       # Bug 3034840
  2106   2110       # Run this test in an interp with memory debugging to panic
  2107   2111       # on the double free
  2108   2112       interp create slave

Changes to tests/ioTrans.test.

  1196   1196   	[catch {interp eval $idb [list close $chan]} msg] $msg
  1197   1197       #lappend res [interp eval $ida {set res}]
  1198   1198       # actions: clear|write|clear|write|clear|flush|limit?|drain|flush
  1199   1199       # The 'tell' is ok, as it passed through the transform to the base channel
  1200   1200       # without invoking the transform handler.
  1201   1201   } -cleanup {
  1202   1202       tempdone
         1203  +    interp delete $idb
  1203   1204   } -result {1 {Owner lost} 0 0 1 {Owner lost} 1 {Owner lost} 1 {Owner lost}}
  1204   1205   test iortrans-11.1 {origin interpreter of moved transform destroyed during access} -setup {
  1205   1206       set ida [interp create];	#puts <<$ida>>
  1206   1207       set idb [interp create];	#puts <<$idb>>
  1207   1208       # Magic to get the test* commands in the slaves
  1208   1209       load {} Tcltest $ida
  1209   1210       load {} Tcltest $idb
................................................................................
  1236   1237   	# wait for the response from B
  1237   1238   	after 50
  1238   1239   	catch { puts $chan shoo } res
  1239   1240   	set res
  1240   1241       }]
  1241   1242   } -cleanup {
  1242   1243       tempdone
         1244  +    interp delete $idb
  1243   1245   } -result {Owner lost}
  1244   1246   test iortrans-11.2 {delete interp of reflected transform} -setup {
  1245   1247       interp create slave
  1246   1248       # Magic to get the test* commands into the slave
  1247   1249       load {} Tcltest slave
  1248   1250   } -constraints {testchannel} -body {
  1249   1251       # Get base channel into the slave

Changes to tests/msgcat.test.

    51     51       variable body
    52     52       variable result
    53     53       variable setVars
    54     54       foreach setVars [PowerSet $envVars] {
    55     55   	set result [string tolower [lindex $setVars 0]]
    56     56   	if {[string length $result] == 0} {
    57     57   	    if {[info exists ::tcl::mac::locale]} {
           58  +if {[package vsatisfies [package provide msgcat] 1.7]} {
           59  +		set result [string tolower \
           60  +			[msgcat::mcutil::ConvertLocale $::tcl::mac::locale]]
           61  +} else {
    58     62   		set result [string tolower \
    59     63   			[msgcat::ConvertLocale $::tcl::mac::locale]]
           64  +}
    60     65   	    } else {
    61     66   		if {([info sharedlibextension] eq ".dll")
    62     67   			&& ![catch {package require registry}]} {
    63     68   		    # Windows and Cygwin have other ways to determine the
    64     69   		    # locale when the environment variables are missing
    65     70   		    # and the registry package is present
    66     71   		    continue
................................................................................
   189    194       test msgcat-1.13 {mclocale set, reject evil input} -setup {
   190    195   	variable locale [mclocale]
   191    196       } -cleanup {
   192    197   	mclocale $locale
   193    198       } -body {
   194    199   	mclocale looks/ok/../../../../but/is/path/to/evil/code
   195    200       } -returnCodes error -match glob -result {invalid newLocale value *}
          201  +
          202  +    test msgcat-1.14 {mcpreferences, custom locale preferences} -setup {
          203  +	variable locale [mclocale]
          204  +	mclocale en
          205  +	mcpreferences fr en {}
          206  +    } -cleanup {
          207  +	mclocale $locale
          208  +    } -body {
          209  +	mcpreferences
          210  +    } -result {fr en {}}
          211  +
          212  +    test msgcat-1.15 {mcpreferences, overwrite custom locale preferences}\
          213  +    -setup {
          214  +	variable locale [mclocale]
          215  +	mcpreferences fr en {}
          216  +	mclocale en
          217  +    } -cleanup {
          218  +	mclocale $locale
          219  +    } -body {
          220  +	mcpreferences
          221  +    } -result {en {}}
          222  +
   196    223   
   197    224       # Tests msgcat-2.*: [mcset], [mcmset], namespace partitioning
   198    225   
   199    226       test msgcat-2.1 {mcset, global scope} {
   200    227   	namespace eval :: ::msgcat::mcset  foo_BAR text1 text2
   201    228       } {text2}
   202    229   
................................................................................
   684    711       removeDirectory msgdir3
   685    712   
   686    713       # Tests msgcat-9.*: [mcexists]
   687    714   
   688    715   	test msgcat-9.1 {mcexists no parameter} -body {
   689    716   	    mcexists
   690    717   	} -returnCodes 1\
   691         -	-result {wrong # args: should be "mcexists ?-exactnamespace? ?-exactlocale? src"}
          718  +	-result {wrong # args: should be "mcexists ?-exactnamespace? ?-exactlocale? ?-namespace ns? src"}
   692    719   
   693    720   	test msgcat-9.2 {mcexists unknown option} -body {
   694    721   	    mcexists -unknown src
   695    722   	} -returnCodes 1\
   696    723   	-result {unknown option "-unknown"}
   697    724   
   698    725   	test msgcat-9.3 {mcexists} -setup {
................................................................................
   720    747   	test msgcat-9.5 {mcexists parent namespace} -setup {
   721    748   	    mcforgetpackage
   722    749   	    variable locale [mclocale]
   723    750   	    mclocale foo_bar
   724    751   	    mcset foo k1 v1
   725    752   	} -cleanup {
   726    753   	    mclocale $locale
          754  +	    namespace delete ::foo
   727    755   	} -body {
   728         -	    namespace eval ::msgcat::test::sub {
          756  +	    namespace eval ::foo {
          757  +		list [::msgcat::mcexists k1]\
          758  +			[::msgcat::mcexists -namespace ::msgcat::test k1]
          759  +	    }
          760  +	} -result {0 1}
          761  +
          762  +	test msgcat-9.6 {mcexists -namespace ns parameter} -setup {
          763  +	    mcforgetpackage
          764  +	    variable locale [mclocale]
          765  +	    mclocale foo_bar
          766  +	    mcset foo k1 v1
          767  +	} -cleanup {
          768  +	    mclocale $locale
          769  +	    namespace delete ::foo
          770  +	} -body {
          771  +	    namespace eval ::foo {
   729    772   		list [::msgcat::mcexists k1]\
   730         -			[::msgcat::mcexists -exactnamespace k1]
          773  +			[::msgcat::mcexists -namespace ::msgcat::test k1]
   731    774   	    }
   732         -	} -result {1 0}
          775  +	} -result {0 1}
          776  +
          777  +	test msgcat-9.7 {mcexists -namespace - ns argument missing} -body {
          778  +	    mcexists -namespace src
          779  +	} -returnCodes 1\
          780  +	-result {Argument missing for switch "-namespace"}
          781  +
   733    782   
   734    783       # Tests msgcat-10.*: [mcloadedlocales]
   735    784   
   736    785   	test msgcat-10.1 {mcloadedlocales no arg} -body {
   737    786   	    mcloadedlocales
   738    787   	} -returnCodes 1\
   739    788   	-result {wrong # args: should be "mcloadedlocales subcommand"}
................................................................................
   807    856   	} -result {1 0}
   808    857   
   809    858       # Tests msgcat-12.*: [mcpackagelocale]
   810    859   
   811    860   	test msgcat-12.1 {mcpackagelocale no subcommand} -body {
   812    861   	    mcpackagelocale
   813    862   	} -returnCodes 1\
   814         -	-result {wrong # args: should be "mcpackagelocale subcommand ?locale?"}
          863  +	-result {wrong # args: should be "mcpackagelocale subcommand ?arg ...?"}
   815    864   
   816    865   	test msgcat-12.2 {mclpackagelocale wrong subcommand} -body {
   817    866   	    mcpackagelocale junk
   818    867   	} -returnCodes 1\
   819    868   	-result {unknown subcommand "junk": must be clear, get, isset, loaded, present, set, or unset}
   820    869   
          870  +	test msgcat-12.2.1 {mclpackagelocale set multiple args} -body {
          871  +	    mcpackagelocale set a b
          872  +	} -returnCodes 1\
          873  +	-result {wrong # args: should be "mcpackagelocale set ?locale?"}
          874  +
   821    875   	test msgcat-12.3 {mcpackagelocale set} -setup {
   822    876   	    variable locale [mclocale]
   823    877   	} -cleanup {
   824    878   	    mclocale $locale
   825    879   	    mcforgetpackage
   826    880   	} -body {
   827    881   	    mclocale foo
................................................................................
   918    972   	    mcloadedlocales clear
   919    973   	    mclocale foo
   920    974   	    mcpackagelocale set bar
   921    975   	    mcpackagelocale clear
   922    976   	    list [mcpackagelocale present foo] [mcpackagelocale present bar]
   923    977   	} -result {0 1}
   924    978   
          979  +	test msgcat-12.11 {mcpackagelocale custom preferences} -setup {
          980  +	    variable locale [mclocale]
          981  +	} -cleanup {
          982  +	    mclocale $locale
          983  +	    mcforgetpackage
          984  +	} -body {
          985  +	    mclocale foo
          986  +	    set res [list [mcpackagelocale preferences]]
          987  +	    mcpackagelocale preferences bar {}
          988  +	    lappend res [mcpackagelocale preferences]
          989  +	} -result {{foo {}} {bar {}}}
          990  +
          991  +	test msgcat-12.12 {mcpackagelocale preferences -> no isset} -setup {
          992  +	    variable locale [mclocale]
          993  +	} -cleanup {
          994  +	    mclocale $locale
          995  +	    mcforgetpackage
          996  +	} -body {
          997  +	    mclocale foo
          998  +	    mcpackagelocale preferences
          999  +	    mcpackagelocale isset
         1000  +	} -result {0}
         1001  +
         1002  +	
   925   1003       # Tests msgcat-13.*: [mcpackageconfig subcmds]
   926   1004   
   927   1005   	test msgcat-13.1 {mcpackageconfig no subcommand} -body {
   928   1006   	    mcpackageconfig
   929   1007   	} -returnCodes 1\
   930   1008   	-result {wrong # args: should be "mcpackageconfig subcommand option ?value?"}
   931   1009   
................................................................................
  1068   1146   	    mcforgetpackage
  1069   1147   	} -body {
  1070   1148   	    mcpackageconfig set unknowncmd [namespace code callbackfailproc]
  1071   1149   	    mclocale foo_bar
  1072   1150   	    mc k1
  1073   1151   	} -returnCodes 1\
  1074   1152   	-result {fail}
         1153  +
         1154  +
         1155  +    # Tests msgcat-15.*: tcloo coverage
         1156  +    
         1157  +    # There are 4 use-cases, where 3 must be tested now:
         1158  +    # - namespace defined, in class definition, class defined oo, classless
         1159  +
         1160  +    test msgcat-15.1 {mc in class setup} -setup {
         1161  +	# full namespace is ::msgcat::test:bar
         1162  +	namespace eval bar {
         1163  +	    ::msgcat::mcset foo_BAR con2 con2bar
         1164  +	    oo::class create ClassCur
         1165  +	}
         1166  +	variable locale [mclocale]
         1167  +	mclocale foo_BAR
         1168  +    } -cleanup {
         1169  +	mclocale $locale
         1170  +	namespace eval bar {::msgcat::mcforgetpackage}
         1171  +	namespace delete bar
         1172  +    } -body {
         1173  +	oo::define bar::ClassCur msgcat::mc con2
         1174  +    } -result con2bar
         1175  +
         1176  +    test msgcat-15.2 {mc in class} -setup {
         1177  +	# full namespace is ::msgcat::test:bar
         1178  +	namespace eval bar {
         1179  +	    ::msgcat::mcset foo_BAR con2 con2bar
         1180  +	    oo::class create ClassCur
         1181  +	    oo::define ClassCur method method1 {} {::msgcat::mc con2}
         1182  +	}
         1183  +	# full namespace is ::msgcat::test:baz
         1184  +	namespace eval baz {
         1185  +            set ObjCur [::msgcat::test::bar::ClassCur new]
         1186  +	}
         1187  +	variable locale [mclocale]
         1188  +	mclocale foo_BAR
         1189  +    } -cleanup {
         1190  +	mclocale $locale
         1191  +	namespace eval bar {::msgcat::mcforgetpackage}
         1192  +	namespace delete bar baz
         1193  +    } -body {
         1194  +	$baz::ObjCur method1
         1195  +    } -result con2bar
         1196  +
         1197  +    test msgcat-15.3 {mc in classless object} -setup {
         1198  +	# full namespace is ::msgcat::test:bar
         1199  +	namespace eval bar {
         1200  +	    ::msgcat::mcset foo_BAR con2 con2bar
         1201  +	    oo::object create ObjCur
         1202  +	    oo::objdefine ObjCur method method1 {} {::msgcat::mc con2}
         1203  +	}
         1204  +	variable locale [mclocale]
         1205  +	mclocale foo_BAR
         1206  +    } -cleanup {
         1207  +	mclocale $locale
         1208  +	namespace eval bar {::msgcat::mcforgetpackage}
         1209  +	namespace delete bar
         1210  +    } -body {
         1211  +	bar::ObjCur method1
         1212  +    } -result con2bar
         1213  +    
         1214  +    test msgcat-15.4 {mc in classless object with explicite namespace eval}\
         1215  +    -setup {
         1216  +	# full namespace is ::msgcat::test:bar
         1217  +	namespace eval bar {
         1218  +	    ::msgcat::mcset foo_BAR con2 con2bar
         1219  +	    oo::object create ObjCur
         1220  +	    oo::objdefine ObjCur method method1 {} {
         1221  +		namespace eval ::msgcat::test::baz {
         1222  +		    ::msgcat::mc con2
         1223  +		}
         1224  +	    }
         1225  +	}
         1226  +	namespace eval baz {
         1227  +	    ::msgcat::mcset foo_BAR con2 con2baz
         1228  +	}
         1229  +	variable locale [mclocale]
         1230  +	mclocale foo_BAR
         1231  +    } -cleanup {
         1232  +	mclocale $locale
         1233  +	namespace eval bar {::msgcat::mcforgetpackage}
         1234  +	namespace eval baz {::msgcat::mcforgetpackage}
         1235  +	namespace delete bar baz
         1236  +    } -body {
         1237  +	bar::ObjCur method1
         1238  +    } -result con2baz
         1239  +    
         1240  +    # Test msgcat-16.*: command mcpackagenamespaceget
         1241  +
         1242  +    test msgcat-16.1 {mcpackagenamespaceget in namespace procedure} -body {
         1243  +	namespace eval baz {msgcat::mcpackagenamespaceget}
         1244  +    } -result ::msgcat::test::baz
         1245  +
         1246  +    test msgcat-16.2 {mcpackagenamespaceget in class setup} -setup {
         1247  +	namespace eval bar {
         1248  +	    oo::class create ClassCur
         1249  +	    oo::define ClassCur variable a
         1250  +	}
         1251  +    } -cleanup {
         1252  +	namespace delete bar
         1253  +    } -body {
         1254  +	oo::define bar::ClassCur msgcat::mcpackagenamespaceget
         1255  +    } -result ::msgcat::test::bar
         1256  +
         1257  +    test msgcat-16.3 {mcpackagenamespaceget in class} -setup {
         1258  +	namespace eval bar {
         1259  +	    oo::class create ClassCur
         1260  +	    oo::define ClassCur method method1 {} {msgcat::mcpackagenamespaceget}
         1261  +	}
         1262  +	namespace eval baz {
         1263  +            set ObjCur [::msgcat::test::bar::ClassCur new]
         1264  +	}
         1265  +    } -cleanup {
         1266  +	namespace delete bar baz
         1267  +    } -body {
         1268  +	$baz::ObjCur method1
         1269  +    } -result ::msgcat::test::bar
         1270  +
         1271  +    test msgcat-16.4 {mcpackagenamespaceget in classless object} -setup {
         1272  +	namespace eval bar {
         1273  +	    oo::object create ObjCur
         1274  +	    oo::objdefine ObjCur method method1 {} {msgcat::mcpackagenamespaceget}
         1275  +	}
         1276  +    } -cleanup {
         1277  +	namespace delete bar
         1278  +    } -body {
         1279  +	bar::ObjCur method1
         1280  +    } -result ::msgcat::test::bar
         1281  +
         1282  +    test msgcat-16.5\
         1283  +    {mcpackagenamespaceget in classless object with explicite namespace eval}\
         1284  +    -setup {
         1285  +	namespace eval bar {
         1286  +	    oo::object create ObjCur
         1287  +	    oo::objdefine ObjCur method method1 {} {
         1288  +		namespace eval ::msgcat::test::baz {
         1289  +		    msgcat::mcpackagenamespaceget
         1290  +		}
         1291  +	    }
         1292  +	}
         1293  +    } -cleanup {
         1294  +	namespace delete bar baz
         1295  +    } -body {
         1296  +	bar::ObjCur method1
         1297  +    } -result ::msgcat::test::baz
         1298  +
         1299  +
         1300  +    # Test msgcat-17.*: mcn command
         1301  +    
         1302  +    test msgcat-17.1 {mcn no parameters} -body {
         1303  +	mcn
         1304  +    } -returnCodes 1\
         1305  +    -result {wrong # args: should be "mcn ns src ?arg ...?"}
         1306  +
         1307  +    test msgcat-17.2 {mcn} -setup {
         1308  +	namespace eval bar {::msgcat::mcset foo_BAR con1 con1bar}
         1309  +	variable locale [mclocale]
         1310  +	mclocale foo_BAR
         1311  +    } -cleanup {
         1312  +	mclocale $locale
         1313  +    } -body {
         1314  +	::msgcat::mcn [namespace current]::bar con1
         1315  +    } -result con1bar
         1316  +
  1075   1317   
  1076   1318       interp bgerror {} $bgerrorsaved
  1077   1319   
         1320  +    # Tests msgcat-15.*: [mcutil]
         1321  +
         1322  +    test msgcat-15.1 {mcutil - no argument} -body {
         1323  +	mcutil
         1324  +    } -returnCodes 1\
         1325  +    -result {wrong # args: should be "mcutil subcommand ?arg ...?"}
         1326  +
         1327  +    test msgcat-15.2 {mcutil - wrong argument} -body {
         1328  +	mcutil junk
         1329  +    } -returnCodes 1\
         1330  +    -result {unknown subcommand "junk": must be getpreferences, or getsystemlocale}
         1331  +    
         1332  +    test msgcat-15.3 {mcutil - partial argument} -body {
         1333  +	mcutil getsystem
         1334  +    } -returnCodes 1\
         1335  +    -result {unknown subcommand "getsystem": must be getpreferences, or getsystemlocale}
         1336  +    
         1337  +    test msgcat-15.4 {mcutil getpreferences - no argument} -body {
         1338  +	mcutil getpreferences
         1339  +    } -returnCodes 1\
         1340  +    -result {wrong # args: should be "mcutil getpreferences locale"}
         1341  +    
         1342  +    test msgcat-15.5 {mcutil getpreferences - DE_de} -body {
         1343  +	mcutil getpreferences DE_de
         1344  +    } -result {de_de de {}}
         1345  +    
         1346  +    test msgcat-15.6 {mcutil getsystemlocale - wrong argument} -body {
         1347  +	mcutil getsystemlocale DE_de
         1348  +    } -returnCodes 1\
         1349  +    -result {wrong # args: should be "mcutil getsystemlocale"}
         1350  +    
         1351  +    # The result is system dependent
         1352  +    # So just test if it runs
         1353  +    # The environment variable version was test with test 0.x
         1354  +    test msgcat-15.7 {mcutil getsystemlocale} -body {
         1355  +	mcutil getsystemlocale
         1356  +	set ok ok
         1357  +    } -result {ok}
         1358  +    
         1359  +    
  1078   1360       cleanupTests
  1079   1361   }
  1080   1362   namespace delete ::msgcat::test
  1081   1363   return
  1082   1364   
  1083   1365   # Local Variables:
  1084   1366   # mode: tcl
  1085   1367   # End:

Changes to tests/oo.test.

     8      8   # this file, and for a DISCLAIMER OF ALL WARRANTIES.
     9      9   
    10     10   package require TclOO 1.0.3
    11     11   package require tcltest 2
    12     12   if {"::tcltest" in [namespace children]} {
    13     13       namespace import -force ::tcltest::*
    14     14   }
           15  +
           16  +
           17  +# The foundational objects oo::object and oo::class are sensitive to reference
           18  +# counting errors and are deallocated only when an interp is deleted, so in
           19  +# this test suite, interp creation and interp deletion are often used in
           20  +# leaktests in order to leverage this sensitivity.
           21  +
    15     22   
    16     23   testConstraint memory [llength [info commands memory]]
    17     24   if {[testConstraint memory]} {
    18     25       proc getbytes {} {
    19     26   	set lines [split [memory info] \n]
    20     27   	return [lindex $lines 3 3]
    21     28       }
................................................................................
    53     60   test oo-0.4 {basic test of OO's ability to clean up its initial state} -body {
    54     61       leaktest {
    55     62   	oo::class create foo
    56     63   	foo new
    57     64   	foo destroy
    58     65       }
    59     66   } -constraints memory -result 0
    60         -test oo-0.5 {testing literal leak on interp delete} memory {
           67  +test oo-0.5.1 {testing object foundation cleanup} memory {
           68  +    leaktest {
           69  +	interp create foo
           70  +	interp delete foo
           71  +    }
           72  +} 0
           73  +test oo-0.5.2 {testing literal leak on interp delete} memory {
    61     74       leaktest {
    62     75   	interp create foo
    63     76   	foo eval {oo::object new}
    64     77   	interp delete foo
    65     78       }
    66     79   } 0
    67     80   test oo-0.6 {cleaning the core class pair; way #1} -setup {
................................................................................
   261    274   } -body {
   262    275       oo::define B constructor {} {A create test-oo-1.18}
   263    276       B create C
   264    277   } -cleanup {
   265    278       rename test-oo-1.18 {}
   266    279       A destroy
   267    280   } -result ::C
   268         -test oo-1.18.1 {Bug 75b8433707: memory leak in oo-1.18} -setup {
          281  +test oo-1.18.1 {no memory leak: superclass} -setup {
          282  +} -constraints memory -body {
          283  +
          284  +    leaktest {
          285  +	interp create t
          286  +	t eval {
          287  +	    oo::class create A {
          288  +		superclass oo::class
          289  +	    }
          290  +	}
          291  +	interp delete t
          292  +    }
          293  +} -cleanup {
          294  +} -result 0
          295  +test oo-1.18.2 {Bug 75b8433707: memory leak in oo-1.18} -setup {
   269    296       proc test-oo-1.18 {} return
   270    297   } -constraints memory -body {
   271    298       leaktest {
   272    299   	oo::class create A
   273    300   	oo::class create B {superclass A}
   274    301   	oo::define B constructor {} {A create test-oo-1.18}
   275    302   	B create C
   276    303   	A destroy
   277    304       }
   278    305   } -cleanup {
   279    306       rename test-oo-1.18 {}
   280    307   } -result 0
   281         -test oo-1.18.2 {Bug 21c144f0f5} -setup {
          308  +test oo-1.18.3 {Bug 21c144f0f5} -setup {
   282    309       interp create slave
   283    310   } -body {
   284    311       slave eval {
   285    312   	oo::define [oo::class create foo] superclass oo::class
   286    313   	oo::class destroy
   287    314       }
   288    315   } -cleanup {
................................................................................
  1498   1525       }}}
  1499   1526   
  1500   1527       rename obj1 {}
  1501   1528       # No segmentation fault
  1502   1529       return done
  1503   1530   } done
  1504   1531   
  1505         -test oo-11.6 {
         1532  +test oo-11.6.1 {
         1533  +    OO: cleanup of when an class is mixed into itself
         1534  +} -constraints memory -body {
         1535  +    leaktest {
         1536  +	interp create interp1
         1537  +	oo::class create obj1
         1538  +	::oo::define obj1 {self mixin [uplevel 1 {namespace which obj1}]}
         1539  +	rename obj1 {}
         1540  +	interp delete interp1
         1541  +    }
         1542  +} -result 0 -cleanup {
         1543  +}
         1544  +
         1545  +test oo-11.6.2 {
         1546  +    OO: cleanup ReleaseClassContents() where class is mixed into one of its
         1547  +    instances
         1548  +} -constraints memory -body {
         1549  +    leaktest {
         1550  +	interp create interp1
         1551  +	interp1 eval {
         1552  +	    oo::class create obj1
         1553  +	    ::oo::copy obj1 obj2
         1554  +	    rename obj2 {}
         1555  +	    rename obj1 {}
         1556  +	}
         1557  +	interp delete interp1
         1558  +    }
         1559  +} -result 0 -cleanup {
         1560  +}
         1561  +
         1562  +test oo-11.6.3 {
         1563  +    OO: cleanup ReleaseClassContents() where class is mixed into one of its
         1564  +    instances
         1565  +} -constraints memory -body {
         1566  +    leaktest {
         1567  +	interp create interp1
         1568  +	interp1 eval {
         1569  +	    oo::class create obj1
         1570  +	    ::oo::define obj1 {self mixin [uplevel 1 {namespace which obj1}]}
         1571  +
         1572  +	    ::oo::copy obj1 obj2
         1573  +	    rename obj2 {}
         1574  +	    rename obj1 {}
         1575  +	}
         1576  +	interp delete interp1
         1577  +    }
         1578  +} -result 0 -cleanup {
         1579  +}
         1580  +
         1581  +test oo-11.6.4 {
  1506   1582       OO: cleanup ReleaseClassContents() where class is mixed into one of its
  1507   1583       instances
  1508   1584   } -body {
  1509   1585       oo::class create obj1
  1510   1586       ::oo::define obj1 {self mixin [self]}
  1511   1587   
  1512   1588       ::oo::copy obj1 obj2
................................................................................
  2061   2137   } -body {
  2062   2138       namespace eval ::existing {}
  2063   2139       oo::copy Cls {} ::existing
  2064   2140   } -returnCodes error -cleanup {
  2065   2141       Super destroy
  2066   2142       catch {namespace delete ::existing}
  2067   2143   } -result {::existing refers to an existing namespace}
  2068         -test oo-15.13 {OO: object cloning with target NS} -setup {
         2144  +test oo-15.13.1 {
         2145  +    OO: object cloning with target NS
         2146  +    Valgrind will report a leak if the reference count of the namespace isn't
         2147  +    properly incremented.
         2148  +} -setup {
         2149  +    oo::class create Cls {}
         2150  +} -body {
         2151  +    oo::copy Cls Cls2 ::dupens
         2152  +    return done
         2153  +} -cleanup {
         2154  +    Cls destroy
         2155  +    Cls2 destroy
         2156  +} -result done 
         2157  +test oo-15.13.2 {OO: object cloning with target NS} -setup {
  2069   2158       oo::class create Super
  2070   2159       oo::class create Cls {superclass Super}
  2071   2160   } -body {
  2072   2161       list [namespace exist ::dupens] [oo::copy Cls Cls2 ::dupens] [namespace exist ::dupens]
  2073   2162   } -cleanup {
  2074   2163       Super destroy
  2075   2164   } -result {0 ::Cls2 1}
................................................................................
  3657   3746   	}
  3658   3747       }
  3659   3748       list [leaktest {[cls new] destroy}] [info class instances cls]
  3660   3749   } -cleanup {
  3661   3750       cls destroy
  3662   3751   } -result {0 {}}
  3663   3752   
  3664         -oo::class create SampleSlot {
  3665         -    superclass oo::Slot
  3666         -    constructor {} {
  3667         -	variable contents {a b c} ops {}
  3668         -    }
  3669         -    method contents {} {variable contents; return $contents}
  3670         -    method ops {} {variable ops; return $ops}
  3671         -    method Get {} {
  3672         -	variable contents
  3673         -	variable ops
  3674         -	lappend ops [info level] Get
  3675         -	return $contents
  3676         -    }
  3677         -    method Set {lst} {
  3678         -	variable contents $lst
  3679         -	variable ops
  3680         -	lappend ops [info level] Set $lst
  3681         -	return
  3682         -    }
         3753  +proc SampleSlotSetup script {
         3754  +    set script0 {
         3755  +	oo::class create SampleSlot {
         3756  +	    superclass oo::Slot
         3757  +	    constructor {} {
         3758  +		variable contents {a b c} ops {}
         3759  +	    }
         3760  +	    method contents {} {variable contents; return $contents}
         3761  +	    method ops {} {variable ops; return $ops}
         3762  +	    method Get {} {
         3763  +		variable contents
         3764  +		variable ops
         3765  +		lappend ops [info level] Get
         3766  +		return $contents
         3767  +	    }
         3768  +	    method Set {lst} {
         3769  +		variable contents $lst
         3770  +		variable ops
         3771  +		lappend ops [info level] Set $lst
         3772  +		return
         3773  +	    }
         3774  +	}
         3775  +    }
         3776  +    append script0 \n$script
         3777  +}
         3778  +
         3779  +proc SampleSlotCleanup script {
         3780  +    set script0 {
         3781  +	SampleSlot destroy
         3782  +    }
         3783  +    append script \n$script0
  3683   3784   }
  3684   3785   
  3685         -test oo-32.1 {TIP 380: slots - class test} -setup {
         3786  +test oo-32.1 {TIP 380: slots - class test} -setup [SampleSlotSetup {
  3686   3787       SampleSlot create sampleSlot
  3687         -} -body {
         3788  +}] -body {
  3688   3789       list [info level] [sampleSlot contents] [sampleSlot ops]
  3689         -} -cleanup {
         3790  +} -cleanup [SampleSlotCleanup {
  3690   3791       rename sampleSlot {}
  3691         -} -result {0 {a b c} {}}
  3692         -test oo-32.2 {TIP 380: slots - class test} -setup {
         3792  +}] -result {0 {a b c} {}}
         3793  +test oo-32.2 {TIP 380: slots - class test} -setup [SampleSlotSetup {
  3693   3794       SampleSlot create sampleSlot
  3694         -} -body {
         3795  +}] -body {
  3695   3796       list [info level] [sampleSlot -clear] \
  3696   3797   	[sampleSlot contents] [sampleSlot ops]
  3697         -} -cleanup {
         3798  +} -cleanup [SampleSlotCleanup {
  3698   3799       rename sampleSlot {}
  3699         -} -result {0 {} {} {1 Set {}}}
  3700         -test oo-32.3 {TIP 380: slots - class test} -setup {
         3800  +}] -result {0 {} {} {1 Set {}}}
         3801  +test oo-32.3 {TIP 380: slots - class test} -setup [SampleSlotSetup {
  3701   3802       SampleSlot create sampleSlot
  3702         -} -body {
         3803  +}] -body {
  3703   3804       list [info level] [sampleSlot -append g h i] \
  3704   3805   	[sampleSlot contents] [sampleSlot ops]
  3705         -} -cleanup {
         3806  +} -cleanup [SampleSlotCleanup {
  3706   3807       rename sampleSlot {}
  3707         -} -result {0 {} {a b c g h i} {1 Get 1 Set {a b c g h i}}}
  3708         -test oo-32.4 {TIP 380: slots - class test} -setup {
         3808  +}] -result {0 {} {a b c g h i} {1 Get 1 Set {a b c g h i}}}
         3809  +test oo-32.4 {TIP 380: slots - class test} -setup [SampleSlotSetup {
  3709   3810       SampleSlot create sampleSlot
  3710         -} -body {
         3811  +}] -body {
  3711   3812       list [info level] [sampleSlot -set d e f] \
  3712   3813   	[sampleSlot contents] [sampleSlot ops]
  3713         -} -cleanup {
         3814  +} -cleanup [SampleSlotCleanup {
  3714   3815       rename sampleSlot {}
  3715         -} -result {0 {} {d e f} {1 Set {d e f}}}
  3716         -test oo-32.5 {TIP 380: slots - class test} -setup {
         3816  +}] -result {0 {} {d e f} {1 Set {d e f}}}
         3817  +test oo-32.5 {TIP 380: slots - class test} -setup [SampleSlotSetup {
  3717   3818       SampleSlot create sampleSlot
  3718         -} -body {
         3819  +}] -body {
  3719   3820       list [info level] [sampleSlot -set d e f] [sampleSlot -append g h i] \
  3720   3821   	[sampleSlot contents] [sampleSlot ops]
  3721         -} -cleanup {
         3822  +} -cleanup [SampleSlotCleanup {
  3722   3823       rename sampleSlot {}
  3723         -} -result {0 {} {} {d e f g h i} {1 Set {d e f} 1 Get 1 Set {d e f g h i}}}
         3824  +}] -result {0 {} {} {d e f g h i} {1 Set {d e f} 1 Get 1 Set {d e f g h i}}}
  3724   3825   
  3725         -test oo-33.1 {TIP 380: slots - defaulting} -setup {
         3826  +test oo-33.1 {TIP 380: slots - defaulting} -setup [SampleSlotSetup {
  3726   3827       set s [SampleSlot new]
  3727         -} -body {
         3828  +}] -body {
  3728   3829       list [$s x y] [$s contents]
  3729         -} -cleanup {
         3830  +} -cleanup [SampleSlotCleanup {
  3730   3831       rename $s {}
  3731         -} -result {{} {a b c x y}}
  3732         -test oo-33.2 {TIP 380: slots - defaulting} -setup {
         3832  +}] -result {{} {a b c x y}}
         3833  +test oo-33.2 {TIP 380: slots - defaulting} -setup [SampleSlotSetup {
  3733   3834       set s [SampleSlot new]
  3734         -} -body {
         3835  +}] -body {
  3735   3836       list [$s destroy; $s unknown] [$s contents]
  3736         -} -cleanup {
         3837  +} -cleanup [SampleSlotCleanup {
  3737   3838       rename $s {}
  3738         -} -result {{} {a b c destroy unknown}}
  3739         -test oo-33.3 {TIP 380: slots - defaulting} -setup {
         3839  +}] -result {{} {a b c destroy unknown}}
         3840  +test oo-33.3 {TIP 380: slots - defaulting} -setup [SampleSlotSetup {
  3740   3841       set s [SampleSlot new]
  3741         -} -body {
         3842  +}] -body {
  3742   3843       oo::objdefine $s forward --default-operation  my -set
  3743   3844       list [$s destroy; $s unknown] [$s contents] [$s ops]
  3744         -} -cleanup {
         3845  +} -cleanup [SampleSlotCleanup {
  3745   3846       rename $s {}
  3746         -} -result {{} unknown {1 Set destroy 1 Set unknown}}
  3747         -test oo-33.4 {TIP 380: slots - errors} -setup {
         3847  +}] -result {{} unknown {1 Set destroy 1 Set unknown}}
         3848  +test oo-33.4 {TIP 380: slots - errors} -setup [SampleSlotSetup {
  3748   3849       set s [SampleSlot new]
  3749         -} -body {
         3850  +}] -body {
  3750   3851       # Method names beginning with "-" are special to slots
  3751   3852       $s -grill q
  3752         -} -returnCodes error -cleanup {
         3853  +} -returnCodes error -cleanup [SampleSlotCleanup {
  3753   3854       rename $s {}
  3754         -} -result {unknown method "-grill": must be -append, -clear, -set, contents or ops}
  3755         -
  3756         -SampleSlot destroy
         3855  +}] -result \
         3856  +    {unknown method "-grill": must be -append, -clear, -set, contents or ops}
  3757   3857   
  3758   3858   test oo-34.1 {TIP 380: slots - presence} -setup {
  3759   3859       set obj [oo::object new]
  3760   3860       set result {}
  3761   3861   } -body {
  3762   3862       oo::define oo::object {
  3763   3863   	::lappend ::result [::info object class filter]

Added tests/process.test.

            1  +# process.test --
            2  +#
            3  +# This file contains a collection of tests for the tcl::process ensemble.
            4  +# Sourcing this file into Tcl runs the tests and generates output for
            5  +# errors.  No output means no errors were found.
            6  +#
            7  +# Copyright (c) 2017 Frederic Bonnet
            8  +# See the file "license.terms" for information on usage and redistribution of
            9  +# this file, and for a DISCLAIMER OF ALL WARRANTIES.
           10  +
           11  +if {[lsearch [namespace children] ::tcltest] == -1} {
           12  +    package require tcltest 2
           13  +    namespace import -force ::tcltest::*
           14  +}
           15  +
           16  +test process-1.1 {tcl::process command basic syntax} -returnCodes error -body {
           17  +    tcl::process
           18  +} -result {wrong # args: should be "tcl::process subcommand ?arg ...?"}
           19  +test process-1.2 {tcl::process command basic syntax} -returnCodes error -body {
           20  +    tcl::process ?
           21  +} -match glob -result {unknown or ambiguous subcommand "?": must be autopurge, list, purge, or status}
           22  +
           23  +test process-2.1 {tcl::process autopurge get} {tcl::process autopurge} {1}
           24  +test process-2.2 {tcl::process autopurge set true} {
           25  +    tcl::process autopurge true
           26  +    tcl::process autopurge
           27  +} {1}
           28  +test process-2.3 {tcl::process autopurge set false} {
           29  +    tcl::process autopurge false
           30  +    tcl::process autopurge
           31  +} {0}

Changes to tests/string.test.

  1389   1389   } {foo}
  1390   1390   test string-14.17 {string replace} {
  1391   1391       string replace abcdefghijklmnop end end-1
  1392   1392   } {abcdefghijklmnop}
  1393   1393   test string-14.18 {string replace} {
  1394   1394       string replace abcdefghijklmnop 10 9 XXX
  1395   1395   } {abcdefghijklmnop}
         1396  +test string-14.19 {string replace} {
         1397  +    string replace {} -1 0 A
         1398  +} A
  1396   1399   
  1397   1400   test string-15.1 {string tolower too few args} {
  1398   1401       list [catch {string tolower} msg] $msg
  1399   1402   } {1 {wrong # args: should be "string tolower string ?first? ?last?"}}
  1400   1403   test string-15.2 {string tolower bad args} {
  1401   1404       list [catch {string tolower a b} msg] $msg
  1402   1405   } {1 {bad index "b": must be integer?[+-]integer? or end?[+-]integer?}}

Changes to unix/Makefile.in.

   299    299   	tclEnv.o tclEvent.o tclExecute.o tclFCmd.o tclFileName.o tclGet.o \
   300    300   	tclHash.o tclHistory.o tclIndexObj.o tclInterp.o tclIO.o tclIOCmd.o \
   301    301   	tclIORChan.o tclIORTrans.o tclIOGT.o tclIOSock.o tclIOUtil.o \
   302    302   	tclLink.o tclListObj.o \
   303    303   	tclLiteral.o tclLoad.o tclMain.o tclNamesp.o tclNotify.o \
   304    304   	tclObj.o tclOptimize.o tclPanic.o tclParse.o tclPathObj.o tclPipe.o \
   305    305   	tclPkg.o tclPkgConfig.o tclPosixStr.o \
   306         -	tclPreserve.o tclProc.o tclRegexp.o \
          306  +	tclPreserve.o tclProc.o tclProcess.o tclRegexp.o \
   307    307   	tclResolve.o tclResult.o tclScan.o tclStringObj.o \
   308    308   	tclStrToD.o tclThread.o \
   309    309   	tclThreadAlloc.o tclThreadJoin.o tclThreadStorage.o tclStubInit.o \
   310    310   	tclTimer.o tclTrace.o tclUtf.o tclUtil.o tclVar.o tclZlib.o \
   311    311   	tclTomMathInterface.o
   312    312   
   313    313   OO_OBJS = tclOO.o tclOOBasic.o tclOOCall.o tclOODefineCmds.o tclOOInfo.o \
................................................................................
   440    440   	$(GENERIC_DIR)/tclPathObj.c \
   441    441   	$(GENERIC_DIR)/tclPipe.c \
   442    442   	$(GENERIC_DIR)/tclPkg.c \
   443    443   	$(GENERIC_DIR)/tclPkgConfig.c \
   444    444   	$(GENERIC_DIR)/tclPosixStr.c \
   445    445   	$(GENERIC_DIR)/tclPreserve.c \
   446    446   	$(GENERIC_DIR)/tclProc.c \
          447  +	$(GENERIC_DIR)/tclProcess.c \
   447    448   	$(GENERIC_DIR)/tclRegexp.c \
   448    449   	$(GENERIC_DIR)/tclResolve.c \
   449    450   	$(GENERIC_DIR)/tclResult.c \
   450    451   	$(GENERIC_DIR)/tclScan.c \
   451    452   	$(GENERIC_DIR)/tclStubInit.c \
   452    453   	$(GENERIC_DIR)/tclStringObj.c \
   453    454   	$(GENERIC_DIR)/tclStrToD.c \
................................................................................
   846    847   	@echo "Installing package http 2.8.12 as a Tcl Module";
   847    848   	@$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.6/http-2.8.12.tm;
   848    849   	@echo "Installing package opt0.4 files to $(SCRIPT_INSTALL_DIR)/opt0.4/";
   849    850   	@for i in $(TOP_DIR)/library/opt/*.tcl ; \
   850    851   	    do \
   851    852   	    $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/opt0.4; \
   852    853   	    done;
   853         -	@echo "Installing package msgcat 1.6.1 as a Tcl Module";
   854         -	@$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/msgcat-1.6.1.tm;
          854  +	@echo "Installing package msgcat 1.7.0 as a Tcl Module";
          855  +	@$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.7/msgcat-1.7.0.tm;
   855    856   	@echo "Installing package tcltest 2.4.1 as a Tcl Module";
   856    857   	@$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.4.1.tm;
   857    858   
   858    859   	@echo "Installing package platform 1.0.14 as a Tcl Module";
   859    860   	@$(INSTALL_DATA) $(TOP_DIR)/library/platform/platform.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/platform-1.0.14.tm;
   860    861   	@echo "Installing package platform::shell 1.1.4 as a Tcl Module";
   861    862   	@$(INSTALL_DATA) $(TOP_DIR)/library/platform/shell.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/platform/shell-1.1.4.tm;
................................................................................
  1284   1285   
  1285   1286   tclPreserve.o: $(GENERIC_DIR)/tclPreserve.c
  1286   1287   	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclPreserve.c
  1287   1288   
  1288   1289   tclProc.o: $(GENERIC_DIR)/tclProc.c $(COMPILEHDR) $(NREHDR)
  1289   1290   	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclProc.c
  1290   1291   
         1292  +tclProcess.o: $(GENERIC_DIR)/tclProcess.c
         1293  +	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclProcess.c
         1294  +
  1291   1295   tclRegexp.o: $(GENERIC_DIR)/tclRegexp.c $(TCLREHDRS)
  1292   1296   	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclRegexp.c
  1293   1297   
  1294   1298   tclResolve.o: $(GENERIC_DIR)/tclResolve.c
  1295   1299   	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclResolve.c
  1296   1300   
  1297   1301   tclResult.o: $(GENERIC_DIR)/tclResult.c

Changes to win/Makefile.in.

   281    281   	tclPathObj.$(OBJEXT) \
   282    282   	tclPipe.$(OBJEXT) \
   283    283   	tclPkg.$(OBJEXT) \
   284    284   	tclPkgConfig.$(OBJEXT) \
   285    285   	tclPosixStr.$(OBJEXT) \
   286    286   	tclPreserve.$(OBJEXT) \
   287    287   	tclProc.$(OBJEXT) \
          288  +	tclProcess.$(OBJEXT) \
   288    289   	tclRegexp.$(OBJEXT) \
   289    290   	tclResolve.$(OBJEXT) \
   290    291   	tclResult.$(OBJEXT) \
   291    292   	tclScan.$(OBJEXT) \
   292    293   	tclStringObj.$(OBJEXT) \
   293    294   	tclStrToD.$(OBJEXT) \
   294    295   	tclStubInit.$(OBJEXT) \
................................................................................
   655    656   	@echo "Installing package http 2.8.12 as a Tcl Module";
   656    657   	@$(COPY) $(ROOT_DIR)/library/http/http.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.6/http-2.8.12.tm;
   657    658   	@echo "Installing library opt0.4 directory";
   658    659   	@for j in $(ROOT_DIR)/library/opt/*.tcl; \
   659    660   	    do \
   660    661   	    $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/opt0.4"; \
   661    662   	    done;
   662         -	@echo "Installing package msgcat 1.6.1 as a Tcl Module";
   663         -	@$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/msgcat-1.6.1.tm;
          663  +	@echo "Installing package msgcat 1.7.0 as a Tcl Module";
          664  +	@$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.7/msgcat-1.7.0.tm;
   664    665   	@echo "Installing package tcltest 2.4.0 as a Tcl Module";
   665    666   	@$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/tcltest-2.4.0.tm;
   666    667   	@echo "Installing package platform 1.0.14 as a Tcl Module";
   667    668   	@$(COPY) $(ROOT_DIR)/library/platform/platform.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.4/platform-1.0.14.tm;
   668    669   	@echo "Installing package platform::shell 1.1.4 as a Tcl Module";
   669    670   	@$(COPY) $(ROOT_DIR)/library/platform/shell.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.4/platform/shell-1.1.4.tm;
   670    671   	@echo "Installing encodings";

Changes to win/buildall.vc.bat.

    34     34   if defined WINDOWSSDKDIR (goto :startBuilding)
    35     35   
    36     36   :: We need to run the development environment batch script that comes
    37     37   :: with developer studio (v4,5,6,7,etc...)  All have it.  This path
    38     38   :: might not be correct.  You should call it yourself prior to running
    39     39   :: this batchfile.
    40     40   ::
    41         -call "C:\Program Files\Microsoft Developer Studio\vc98\bin\vcvars32.bat"
           41  +REM call "C:\Program Files\Microsoft Developer Studio\vc98\bin\vcvars32.bat"
           42  +set "VSCMD_START_DIR=%CD%"
           43  +call "C:\Program Files (x86)\Microsoft Visual Studio\2017\Community\Common7\Tools\VsDevCmd.bat"
    42     44   if errorlevel 1 (goto no_vcvars)
    43     45   
    44     46   :startBuilding
    45     47   
    46     48   echo.
    47     49   echo Sit back and have a cup of coffee while this grinds through ;)
    48     50   echo You asked for *everything*, remember?

Changes to win/makefile.vc.

   214    214   	$(TMP_DIR)\tclPathObj.obj \
   215    215   	$(TMP_DIR)\tclPipe.obj \
   216    216   	$(TMP_DIR)\tclPkg.obj \
   217    217   	$(TMP_DIR)\tclPkgConfig.obj \
   218    218   	$(TMP_DIR)\tclPosixStr.obj \
   219    219   	$(TMP_DIR)\tclPreserve.obj \
   220    220   	$(TMP_DIR)\tclProc.obj \
          221  +	$(TMP_DIR)\tclProcess.obj \
   221    222   	$(TMP_DIR)\tclRegexp.obj \
   222    223   	$(TMP_DIR)\tclResolve.obj \
   223    224   	$(TMP_DIR)\tclResult.obj \
   224    225   	$(TMP_DIR)\tclScan.obj \
   225    226   	$(TMP_DIR)\tclStringObj.obj \
   226    227   	$(TMP_DIR)\tclStrToD.obj \
   227    228   	$(TMP_DIR)\tclStubInit.obj \
................................................................................
   864    865   	@$(CPY) "$(ROOT)\library\opt\*.tcl" \
   865    866   	    "$(SCRIPT_INSTALL_DIR)\opt0.4\"
   866    867   	@echo Installing package http $(PKG_HTTP_VER) as a Tcl Module
   867    868   	@$(COPY) "$(ROOT)\library\http\http.tcl" \
   868    869   	    "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.6\http-$(PKG_HTTP_VER).tm"
   869    870   	@echo Installing package msgcat $(PKG_MSGCAT_VER) as a Tcl Module
   870    871   	@$(COPY) "$(ROOT)\library\msgcat\msgcat.tcl" \
   871         -	    "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.5\msgcat-$(PKG_MSGCAT_VER).tm"
          872  +	    "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.7\msgcat-$(PKG_MSGCAT_VER).tm"
   872    873   	@echo Installing package tcltest $(PKG_TCLTEST_VER) as a Tcl Module
   873    874   	@$(COPY) "$(ROOT)\library\tcltest\tcltest.tcl" \
   874    875   	    "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.5\tcltest-$(PKG_TCLTEST_VER).tm"
   875    876   	@echo Installing package platform $(PKG_PLATFORM_VER) as a Tcl Module
   876    877   	@$(COPY) "$(ROOT)\library\platform\platform.tcl" \
   877    878   	    "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.4\platform-$(PKG_PLATFORM_VER).tm"
   878    879   	@echo Installing package platform::shell $(PKG_SHELL_VER) as a Tcl Module

Changes to win/tcl.dsp.

  1259   1259   SOURCE=..\generic\tclPreserve.c
  1260   1260   # End Source File
  1261   1261   # Begin Source File
  1262   1262   
  1263   1263   SOURCE=..\generic\tclProc.c
  1264   1264   # End Source File
  1265   1265   # Begin Source File
         1266  +
         1267  +SOURCE=..\generic\tclProcess.c
         1268  +# End Source File
         1269  +# Begin Source File
  1266   1270   
  1267   1271   SOURCE=..\generic\tclRegexp.c
  1268   1272   # End Source File
  1269   1273   # Begin Source File
  1270   1274   
  1271   1275   SOURCE=..\generic\tclRegexp.h
  1272   1276   # End Source File

Changes to win/tclWinPipe.c.

   865    865   {
   866    866       ProcInfo *infoPtr;
   867    867   
   868    868       PipeInit();
   869    869   
   870    870       Tcl_MutexLock(&pipeMutex);
   871    871       for (infoPtr = procList; infoPtr != NULL; infoPtr = infoPtr->nextPtr) {
   872         -	if (infoPtr->hProcess == (HANDLE) pid) {
          872  +	if (infoPtr->dwProcessId == (DWORD) pid) {
   873    873   	    Tcl_MutexUnlock(&pipeMutex);
   874    874   	    return infoPtr->dwProcessId;
   875    875   	}
   876    876       }
   877    877       Tcl_MutexUnlock(&pipeMutex);
   878    878       return (unsigned long) -1;
   879    879   }
................................................................................
  1159   1159        * CreateProcess() and CloseHandle(), the problem does not occur." PSS ID
  1160   1160        * Number: Q124121
  1161   1161        */
  1162   1162   
  1163   1163       WaitForInputIdle(procInfo.hProcess, 5000);
  1164   1164       CloseHandle(procInfo.hThread);
  1165   1165   
  1166         -    *pidPtr = (Tcl_Pid) procInfo.hProcess;
         1166  +    *pidPtr = (Tcl_Pid) procInfo.dwProcessId;
  1167   1167       if (*pidPtr != 0) {
  1168   1168   	TclWinAddProcess(procInfo.hProcess, procInfo.dwProcessId);
  1169   1169       }
  1170   1170       result = TCL_OK;
  1171   1171   
  1172   1172     end:
  1173   1173       Tcl_DStringFree(&cmdLine);
................................................................................
  2343   2343        * Find the process and cut it from the process list.
  2344   2344        */
  2345   2345   
  2346   2346       Tcl_MutexLock(&pipeMutex);
  2347   2347       prevPtrPtr = &procList;
  2348   2348       for (infoPtr = procList; infoPtr != NULL;
  2349   2349   	    prevPtrPtr = &infoPtr->nextPtr, infoPtr = infoPtr->nextPtr) {
  2350         -	 if (infoPtr->hProcess == (HANDLE) pid) {
         2350  +	 if (infoPtr->dwProcessId == (DWORD) pid) {
  2351   2351   	    *prevPtrPtr = infoPtr->nextPtr;
  2352   2352   	    break;
  2353   2353   	}
  2354   2354       }
  2355   2355       Tcl_MutexUnlock(&pipeMutex);
  2356   2356   
  2357   2357       /*