-- cgit v0.12 From c86a23de04031e905caf60b8b28dfeed64b8ba5f Mon Sep 17 00:00:00 2001 From: "f.bonnet" Date: Thu, 17 Aug 2017 13:02:27 +0000 Subject: Basic scaffolding for tcl::process --- generic/tclBasic.c | 1 + generic/tclInt.h | 1 + generic/tclProcess.c | 175 +++++++++++++++++++++++++++++++++++++++++++++++++++ tests/process.test | 21 +++++++ unix/Makefile.in | 6 +- win/Makefile.in | 1 + win/buildall.vc.bat | 4 +- win/makefile.vc | 1 + win/tcl.dsp | 4 ++ 9 files changed, 212 insertions(+), 2 deletions(-) create mode 100644 generic/tclProcess.c create mode 100644 tests/process.test diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 8e816a5..b4821ef 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -813,6 +813,7 @@ Tcl_CreateInterp(void) TclInitNamespaceCmd(interp); TclInitStringCmd(interp); TclInitPrefixCmd(interp); + TclInitProcessCmd(interp); /* * Register "clock" subcommands. These *do* go through diff --git a/generic/tclInt.h b/generic/tclInt.h index 1fbc541..ce6cc1c 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3414,6 +3414,7 @@ MODULE_SCOPE int Tcl_PidObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE Tcl_Command TclInitPrefixCmd(Tcl_Interp *interp); +MODULE_SCOPE Tcl_Command TclInitProcessCmd(Tcl_Interp *interp); MODULE_SCOPE int Tcl_PutsObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); diff --git a/generic/tclProcess.c b/generic/tclProcess.c new file mode 100644 index 0000000..3fcdacd --- /dev/null +++ b/generic/tclProcess.c @@ -0,0 +1,175 @@ +/* + * tclProcess.c -- + * + * This file implements the "tcl::process" ensemble for subprocess + * management as defined by TIP #462. + * + * Copyright (c) 2017 Frederic Bonnet. + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + + #include "tclInt.h" + + /* + * Prototypes for functions defined later in this file: + */ + +static int ProcessListObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static int ProcessStatusObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static int ProcessPurgeObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static int ProcessAutopurgeObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); + +/*---------------------------------------------------------------------- + * + * ProcessListObjCmd -- + * + * This function implements the 'tcl::process list' Tcl command. + * Refer to the user documentation for details on what it does. + * + * Results: + * Returns a standard Tcl result. + * + * Side effects: + * None.TODO + * + *---------------------------------------------------------------------- + */ + + static int + ProcessListObjCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ + { + /* TODO */ + return TCL_ERROR; + } + +/*---------------------------------------------------------------------- + * + * ProcessStatusObjCmd -- + * + * This function implements the 'tcl::process status' Tcl command. + * Refer to the user documentation for details on what it does. + * + * Results: + * Returns a standard Tcl result. + * + * Side effects: + * None.TODO + * + *---------------------------------------------------------------------- + */ + + static int + ProcessStatusObjCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ + { + /* TODO */ + return TCL_ERROR; + } + +/*---------------------------------------------------------------------- + * + * ProcessPurgeObjCmd -- + * + * This function implements the 'tcl::process purge' Tcl command. + * Refer to the user documentation for details on what it does. + * + * Results: + * Returns a standard Tcl result. + * + * Side effects: + * None.TODO + * + *---------------------------------------------------------------------- + */ + + static int + ProcessPurgeObjCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ + { + /* TODO */ + return TCL_ERROR; + } + +/*---------------------------------------------------------------------- + * + * ProcessAutopurgeObjCmd -- + * + * This function implements the 'tcl::process autopurge' Tcl command. + * Refer to the user documentation for details on what it does. + * + * Results: + * Returns a standard Tcl result. + * + * Side effects: + * None.TODO + * + *---------------------------------------------------------------------- + */ + + static int + ProcessAutopurgeObjCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ + { + /* TODO */ + return TCL_ERROR; + } + +/* + *---------------------------------------------------------------------- + * + * TclInitProcessCmd -- + * + * This procedure creates the "tcl::process" Tcl command. See the user + * documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + Tcl_Command + TclInitProcessCmd( + Tcl_Interp *interp) /* Current interpreter. */ + { + static const EnsembleImplMap processImplMap[] = { + {"list", ProcessListObjCmd, TclCompileBasic0ArgCmd, NULL, NULL, 1}, + {"status", ProcessStatusObjCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 1}, + {"purge", ProcessPurgeObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1}, + {"autopurge", ProcessAutopurgeObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1}, + {NULL, NULL, NULL, NULL, NULL, 0} + }; + Tcl_Command processCmd; + + processCmd = TclMakeEnsemble(interp, "::tcl::process", processImplMap); + Tcl_Export(interp, Tcl_FindNamespace(interp, "::tcl", NULL, 0), + "process", 0); + return processCmd; + } + \ No newline at end of file diff --git a/tests/process.test b/tests/process.test new file mode 100644 index 0000000..f3275c8 --- /dev/null +++ b/tests/process.test @@ -0,0 +1,21 @@ +# process.test -- +# +# This file contains a collection of tests for the tcl::process ensemble. +# Sourcing this file into Tcl runs the tests and generates output for +# errors. No output means no errors were found. +# +# Copyright (c) 2017 Frederic Bonnet +# See the file "license.terms" for information on usage and redistribution of +# this file, and for a DISCLAIMER OF ALL WARRANTIES. + +if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest 2 + namespace import -force ::tcltest::* +} + +test process-1.1 {tcl::process command basic syntax} -returnCodes error -body { + tcl::process +} -result {wrong # args: should be "tcl::process subcommand ?arg ...?"} +test process-1.2 {tcl::process command basic syntax} -returnCodes error -body { + tcl::process ? +} -match glob -result {unknown or ambiguous subcommand "?": must be autopurge, list, purge, or status} diff --git a/unix/Makefile.in b/unix/Makefile.in index c4f6136..25aa003 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -303,7 +303,7 @@ GENERIC_OBJS = regcomp.o regexec.o regfree.o regerror.o tclAlloc.o \ tclLiteral.o tclLoad.o tclMain.o tclNamesp.o tclNotify.o \ tclObj.o tclOptimize.o tclPanic.o tclParse.o tclPathObj.o tclPipe.o \ tclPkg.o tclPkgConfig.o tclPosixStr.o \ - tclPreserve.o tclProc.o tclRegexp.o \ + tclPreserve.o tclProc.o tclProcess.o tclRegexp.o \ tclResolve.o tclResult.o tclScan.o tclStringObj.o \ tclStrToD.o tclThread.o \ tclThreadAlloc.o tclThreadJoin.o tclThreadStorage.o tclStubInit.o \ @@ -444,6 +444,7 @@ GENERIC_SRCS = \ $(GENERIC_DIR)/tclPosixStr.c \ $(GENERIC_DIR)/tclPreserve.c \ $(GENERIC_DIR)/tclProc.c \ + $(GENERIC_DIR)/tclProcess.c \ $(GENERIC_DIR)/tclRegexp.c \ $(GENERIC_DIR)/tclResolve.c \ $(GENERIC_DIR)/tclResult.c \ @@ -1286,6 +1287,9 @@ tclPreserve.o: $(GENERIC_DIR)/tclPreserve.c tclProc.o: $(GENERIC_DIR)/tclProc.c $(COMPILEHDR) $(NREHDR) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclProc.c +tclProcess.o: $(GENERIC_DIR)/tclProcess.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclProcess.c + tclRegexp.o: $(GENERIC_DIR)/tclRegexp.c $(TCLREHDRS) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclRegexp.c diff --git a/win/Makefile.in b/win/Makefile.in index e967ef3..ad8db34 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -285,6 +285,7 @@ GENERIC_OBJS = \ tclPosixStr.$(OBJEXT) \ tclPreserve.$(OBJEXT) \ tclProc.$(OBJEXT) \ + tclProcess.$(OBJEXT) \ tclRegexp.$(OBJEXT) \ tclResolve.$(OBJEXT) \ tclResult.$(OBJEXT) \ diff --git a/win/buildall.vc.bat b/win/buildall.vc.bat index deb9e39..cb136be 100644 --- a/win/buildall.vc.bat +++ b/win/buildall.vc.bat @@ -38,7 +38,9 @@ if defined WINDOWSSDKDIR (goto :startBuilding) :: might not be correct. You should call it yourself prior to running :: this batchfile. :: -call "C:\Program Files\Microsoft Developer Studio\vc98\bin\vcvars32.bat" +REM call "C:\Program Files\Microsoft Developer Studio\vc98\bin\vcvars32.bat" +set "VSCMD_START_DIR=%CD%" +call "C:\Program Files (x86)\Microsoft Visual Studio\2017\Community\Common7\Tools\VsDevCmd.bat" if errorlevel 1 (goto no_vcvars) :startBuilding diff --git a/win/makefile.vc b/win/makefile.vc index d6de5e1..bdc8511 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -327,6 +327,7 @@ COREOBJS = \ $(TMP_DIR)\tclPosixStr.obj \ $(TMP_DIR)\tclPreserve.obj \ $(TMP_DIR)\tclProc.obj \ + $(TMP_DIR)\tclProcess.obj \ $(TMP_DIR)\tclRegexp.obj \ $(TMP_DIR)\tclResolve.obj \ $(TMP_DIR)\tclResult.obj \ diff --git a/win/tcl.dsp b/win/tcl.dsp index 48eae9d..e3873a3 100644 --- a/win/tcl.dsp +++ b/win/tcl.dsp @@ -1268,6 +1268,10 @@ SOURCE=..\generic\tclProc.c # End Source File # Begin Source File +SOURCE=..\generic\tclProcess.c +# End Source File +# Begin Source File + SOURCE=..\generic\tclRegexp.c # End Source File # Begin Source File -- cgit v0.12 From 0b8e964f45cff8228e6e64598b7f7f80060aa345 Mon Sep 17 00:00:00 2001 From: "f.bonnet" Date: Thu, 17 Aug 2017 13:03:48 +0000 Subject: Fixed line endings --- generic/tclProcess.c | 348 +++++++++++++++++++++++++-------------------------- tests/process.test | 42 +++---- 2 files changed, 195 insertions(+), 195 deletions(-) diff --git a/generic/tclProcess.c b/generic/tclProcess.c index 3fcdacd..516d0d7 100644 --- a/generic/tclProcess.c +++ b/generic/tclProcess.c @@ -1,175 +1,175 @@ -/* - * tclProcess.c -- - * - * This file implements the "tcl::process" ensemble for subprocess - * management as defined by TIP #462. - * - * Copyright (c) 2017 Frederic Bonnet. - * - * See the file "license.terms" for information on usage and redistribution of - * this file, and for a DISCLAIMER OF ALL WARRANTIES. - */ - - #include "tclInt.h" - - /* - * Prototypes for functions defined later in this file: - */ - -static int ProcessListObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -static int ProcessStatusObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -static int ProcessPurgeObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -static int ProcessAutopurgeObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); - -/*---------------------------------------------------------------------- - * - * ProcessListObjCmd -- - * - * This function implements the 'tcl::process list' Tcl command. - * Refer to the user documentation for details on what it does. - * - * Results: - * Returns a standard Tcl result. - * - * Side effects: - * None.TODO - * - *---------------------------------------------------------------------- - */ - - static int - ProcessListObjCmd( - ClientData clientData, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ - { - /* TODO */ - return TCL_ERROR; - } - -/*---------------------------------------------------------------------- - * - * ProcessStatusObjCmd -- - * - * This function implements the 'tcl::process status' Tcl command. - * Refer to the user documentation for details on what it does. - * - * Results: - * Returns a standard Tcl result. - * - * Side effects: - * None.TODO - * - *---------------------------------------------------------------------- - */ - - static int - ProcessStatusObjCmd( - ClientData clientData, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ - { - /* TODO */ - return TCL_ERROR; - } - -/*---------------------------------------------------------------------- - * - * ProcessPurgeObjCmd -- - * - * This function implements the 'tcl::process purge' Tcl command. - * Refer to the user documentation for details on what it does. - * - * Results: - * Returns a standard Tcl result. - * - * Side effects: - * None.TODO - * - *---------------------------------------------------------------------- - */ - - static int - ProcessPurgeObjCmd( - ClientData clientData, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ - { - /* TODO */ - return TCL_ERROR; - } - -/*---------------------------------------------------------------------- - * - * ProcessAutopurgeObjCmd -- - * - * This function implements the 'tcl::process autopurge' Tcl command. - * Refer to the user documentation for details on what it does. - * - * Results: - * Returns a standard Tcl result. - * - * Side effects: - * None.TODO - * - *---------------------------------------------------------------------- - */ - - static int - ProcessAutopurgeObjCmd( - ClientData clientData, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ - { - /* TODO */ - return TCL_ERROR; - } - -/* - *---------------------------------------------------------------------- - * - * TclInitProcessCmd -- - * - * This procedure creates the "tcl::process" Tcl command. See the user - * documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - - Tcl_Command - TclInitProcessCmd( - Tcl_Interp *interp) /* Current interpreter. */ - { - static const EnsembleImplMap processImplMap[] = { - {"list", ProcessListObjCmd, TclCompileBasic0ArgCmd, NULL, NULL, 1}, - {"status", ProcessStatusObjCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 1}, - {"purge", ProcessPurgeObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1}, - {"autopurge", ProcessAutopurgeObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1}, - {NULL, NULL, NULL, NULL, NULL, 0} - }; - Tcl_Command processCmd; - - processCmd = TclMakeEnsemble(interp, "::tcl::process", processImplMap); - Tcl_Export(interp, Tcl_FindNamespace(interp, "::tcl", NULL, 0), - "process", 0); - return processCmd; - } +/* + * tclProcess.c -- + * + * This file implements the "tcl::process" ensemble for subprocess + * management as defined by TIP #462. + * + * Copyright (c) 2017 Frederic Bonnet. + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + + #include "tclInt.h" + + /* + * Prototypes for functions defined later in this file: + */ + +static int ProcessListObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static int ProcessStatusObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static int ProcessPurgeObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static int ProcessAutopurgeObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); + +/*---------------------------------------------------------------------- + * + * ProcessListObjCmd -- + * + * This function implements the 'tcl::process list' Tcl command. + * Refer to the user documentation for details on what it does. + * + * Results: + * Returns a standard Tcl result. + * + * Side effects: + * None.TODO + * + *---------------------------------------------------------------------- + */ + + static int + ProcessListObjCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ + { + /* TODO */ + return TCL_ERROR; + } + +/*---------------------------------------------------------------------- + * + * ProcessStatusObjCmd -- + * + * This function implements the 'tcl::process status' Tcl command. + * Refer to the user documentation for details on what it does. + * + * Results: + * Returns a standard Tcl result. + * + * Side effects: + * None.TODO + * + *---------------------------------------------------------------------- + */ + + static int + ProcessStatusObjCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ + { + /* TODO */ + return TCL_ERROR; + } + +/*---------------------------------------------------------------------- + * + * ProcessPurgeObjCmd -- + * + * This function implements the 'tcl::process purge' Tcl command. + * Refer to the user documentation for details on what it does. + * + * Results: + * Returns a standard Tcl result. + * + * Side effects: + * None.TODO + * + *---------------------------------------------------------------------- + */ + + static int + ProcessPurgeObjCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ + { + /* TODO */ + return TCL_ERROR; + } + +/*---------------------------------------------------------------------- + * + * ProcessAutopurgeObjCmd -- + * + * This function implements the 'tcl::process autopurge' Tcl command. + * Refer to the user documentation for details on what it does. + * + * Results: + * Returns a standard Tcl result. + * + * Side effects: + * None.TODO + * + *---------------------------------------------------------------------- + */ + + static int + ProcessAutopurgeObjCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ + { + /* TODO */ + return TCL_ERROR; + } + +/* + *---------------------------------------------------------------------- + * + * TclInitProcessCmd -- + * + * This procedure creates the "tcl::process" Tcl command. See the user + * documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + Tcl_Command + TclInitProcessCmd( + Tcl_Interp *interp) /* Current interpreter. */ + { + static const EnsembleImplMap processImplMap[] = { + {"list", ProcessListObjCmd, TclCompileBasic0ArgCmd, NULL, NULL, 1}, + {"status", ProcessStatusObjCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 1}, + {"purge", ProcessPurgeObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1}, + {"autopurge", ProcessAutopurgeObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1}, + {NULL, NULL, NULL, NULL, NULL, 0} + }; + Tcl_Command processCmd; + + processCmd = TclMakeEnsemble(interp, "::tcl::process", processImplMap); + Tcl_Export(interp, Tcl_FindNamespace(interp, "::tcl", NULL, 0), + "process", 0); + return processCmd; + } \ No newline at end of file diff --git a/tests/process.test b/tests/process.test index f3275c8..cef3adc 100644 --- a/tests/process.test +++ b/tests/process.test @@ -1,21 +1,21 @@ -# process.test -- -# -# This file contains a collection of tests for the tcl::process ensemble. -# Sourcing this file into Tcl runs the tests and generates output for -# errors. No output means no errors were found. -# -# Copyright (c) 2017 Frederic Bonnet -# See the file "license.terms" for information on usage and redistribution of -# this file, and for a DISCLAIMER OF ALL WARRANTIES. - -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 - namespace import -force ::tcltest::* -} - -test process-1.1 {tcl::process command basic syntax} -returnCodes error -body { - tcl::process -} -result {wrong # args: should be "tcl::process subcommand ?arg ...?"} -test process-1.2 {tcl::process command basic syntax} -returnCodes error -body { - tcl::process ? -} -match glob -result {unknown or ambiguous subcommand "?": must be autopurge, list, purge, or status} +# process.test -- +# +# This file contains a collection of tests for the tcl::process ensemble. +# Sourcing this file into Tcl runs the tests and generates output for +# errors. No output means no errors were found. +# +# Copyright (c) 2017 Frederic Bonnet +# See the file "license.terms" for information on usage and redistribution of +# this file, and for a DISCLAIMER OF ALL WARRANTIES. + +if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest 2 + namespace import -force ::tcltest::* +} + +test process-1.1 {tcl::process command basic syntax} -returnCodes error -body { + tcl::process +} -result {wrong # args: should be "tcl::process subcommand ?arg ...?"} +test process-1.2 {tcl::process command basic syntax} -returnCodes error -body { + tcl::process ? +} -match glob -result {unknown or ambiguous subcommand "?": must be autopurge, list, purge, or status} -- cgit v0.12 From 5aaef06572dc90a7a493d187959fe9829da27fbb Mon Sep 17 00:00:00 2001 From: "f.bonnet" Date: Fri, 18 Aug 2017 07:51:01 +0000 Subject: Added [tcl::process autopurge] flag management with TclProcessGetAutopurge/TclProcessSetAutopurge companion functions. --- generic/tclInt.h | 9 ++- generic/tclProcess.c | 176 +++++++++++++++++++++++++++++++++++++-------------- tests/process.test | 10 +++ 3 files changed, 148 insertions(+), 47 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index ce6cc1c..a602e6c 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3414,7 +3414,6 @@ MODULE_SCOPE int Tcl_PidObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE Tcl_Command TclInitPrefixCmd(Tcl_Interp *interp); -MODULE_SCOPE Tcl_Command TclInitProcessCmd(Tcl_Interp *interp); MODULE_SCOPE int Tcl_PutsObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -4023,6 +4022,14 @@ MODULE_SCOPE TCL_HASH_TYPE TclHashObjKey(Tcl_HashTable *tablePtr, void *keyPtr); MODULE_SCOPE int TclFullFinalizationRequested(void); /* + * TIP #462. + */ + +MODULE_SCOPE Tcl_Command TclInitProcessCmd(Tcl_Interp *interp); +MODULE_SCOPE int TclProcessGetAutopurge(void); +MODULE_SCOPE void TclProcessSetAutopurge(int flag); + +/* *---------------------------------------------------------------- * Macros used by the Tcl core to create and release Tcl objects. * TclNewObj(objPtr) creates a new object denoting an empty string. diff --git a/generic/tclProcess.c b/generic/tclProcess.c index 516d0d7..23ba4de 100644 --- a/generic/tclProcess.c +++ b/generic/tclProcess.c @@ -10,7 +10,9 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ - #include "tclInt.h" +#include "tclInt.h" + +static int autopurge = 1; /* Autopurge flag. */ /* * Prototypes for functions defined later in this file: @@ -45,13 +47,18 @@ static int ProcessAutopurgeObjCmd(ClientData clientData, *---------------------------------------------------------------------- */ - static int - ProcessListObjCmd( - ClientData clientData, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ - { +static int +ProcessListObjCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return TCL_ERROR; + } + /* TODO */ return TCL_ERROR; } @@ -72,13 +79,18 @@ static int ProcessAutopurgeObjCmd(ClientData clientData, *---------------------------------------------------------------------- */ - static int - ProcessStatusObjCmd( - ClientData clientData, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ - { +static int +ProcessStatusObjCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + if (objc < 1) { + Tcl_WrongNumArgs(interp, 1, objv, "?switches? ?pids?"); + return TCL_ERROR; + } + /* TODO */ return TCL_ERROR; } @@ -99,13 +111,18 @@ static int ProcessAutopurgeObjCmd(ClientData clientData, *---------------------------------------------------------------------- */ - static int - ProcessPurgeObjCmd( - ClientData clientData, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ - { +static int +ProcessPurgeObjCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + if (objc != 1 && objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "?pids?"); + return TCL_ERROR; + } + /* TODO */ return TCL_ERROR; } @@ -126,17 +143,40 @@ static int ProcessAutopurgeObjCmd(ClientData clientData, *---------------------------------------------------------------------- */ - static int - ProcessAutopurgeObjCmd( - ClientData clientData, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ +static int +ProcessAutopurgeObjCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { - /* TODO */ - return TCL_ERROR; - } - + if (objc != 1 && objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "?flag?"); + return TCL_ERROR; + } + + if (objc == 2) { + /* + * Set given value. + */ + + int flag; + int result = Tcl_GetBooleanFromObj(interp, objv[1], &flag); + if (result != TCL_OK) { + return result; + } + + TclProcessSetAutopurge(flag); + } + + /* + * Return current value. + */ + + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(TclProcessGetAutopurge())); + return TCL_OK; +} + /* *---------------------------------------------------------------------- * @@ -154,22 +194,66 @@ static int ProcessAutopurgeObjCmd(ClientData clientData, *---------------------------------------------------------------------- */ - Tcl_Command - TclInitProcessCmd( - Tcl_Interp *interp) /* Current interpreter. */ - { - static const EnsembleImplMap processImplMap[] = { +Tcl_Command +TclInitProcessCmd( + Tcl_Interp *interp) /* Current interpreter. */ +{ + static const EnsembleImplMap processImplMap[] = { {"list", ProcessListObjCmd, TclCompileBasic0ArgCmd, NULL, NULL, 1}, {"status", ProcessStatusObjCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 1}, {"purge", ProcessPurgeObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1}, {"autopurge", ProcessAutopurgeObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1}, {NULL, NULL, NULL, NULL, NULL, 0} - }; - Tcl_Command processCmd; - - processCmd = TclMakeEnsemble(interp, "::tcl::process", processImplMap); - Tcl_Export(interp, Tcl_FindNamespace(interp, "::tcl", NULL, 0), - "process", 0); - return processCmd; - } - \ No newline at end of file + }; + Tcl_Command processCmd; + + processCmd = TclMakeEnsemble(interp, "::tcl::process", processImplMap); + Tcl_Export(interp, Tcl_FindNamespace(interp, "::tcl", NULL, 0), + "process", 0); + return processCmd; +} + +/* + *---------------------------------------------------------------------- + * + * TclProcessGetAutopurge -- + * + * This function queries the value of the autopurge flag. + * + * Results: + * The current boolean value of the autopurge flag. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclProcessGetAutopurge(void) +{ + return autopurge; +} + +/* + *---------------------------------------------------------------------- + * + * TclProcessSetAutopurge -- + * + * This function sets the value of the autopurge flag. + * + * Results: + * None. + * + * Side effects: + * Sets the autopurge static variable. + * + *---------------------------------------------------------------------- + */ + +void +TclProcessSetAutopurge( + int flag) /* New value for autopurge. */ +{ + autopurge = !!flag; +} diff --git a/tests/process.test b/tests/process.test index cef3adc..fb3a5e2 100644 --- a/tests/process.test +++ b/tests/process.test @@ -19,3 +19,13 @@ test process-1.1 {tcl::process command basic syntax} -returnCodes error -body { test process-1.2 {tcl::process command basic syntax} -returnCodes error -body { tcl::process ? } -match glob -result {unknown or ambiguous subcommand "?": must be autopurge, list, purge, or status} + +test process-2.1 {tcl::process autopurge get} {tcl::process autopurge} {1} +test process-2.2 {tcl::process autopurge set true} { + tcl::process autopurge true + tcl::process autopurge +} {1} +test process-2.3 {tcl::process autopurge set false} { + tcl::process autopurge false + tcl::process autopurge +} {0} -- cgit v0.12 From 03470df2ff2414f1912a85772cd6f558196ca8bc Mon Sep 17 00:00:00 2001 From: "f.bonnet" Date: Fri, 18 Aug 2017 12:49:08 +0000 Subject: Completed [tcl::process autopurge] semantics and added [tcl::process purge] implementation along with the necessary internal functions TclpGetChildPid/TclReapPids --- generic/tclInt.h | 2 ++ generic/tclIntPlatDecls.h | 2 ++ generic/tclPipe.c | 59 ++++++++++++++++++++++++++++++++++++++++++++++- generic/tclProcess.c | 45 +++++++++++++++++++++++++++++++++--- unix/tclUnixPipe.c | 4 +++- win/tclWinPipe.c | 42 ++++++++++++++++++++++++++++++++- 6 files changed, 148 insertions(+), 6 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index a602e6c..3e99f91 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4028,6 +4028,8 @@ MODULE_SCOPE int TclFullFinalizationRequested(void); MODULE_SCOPE Tcl_Command TclInitProcessCmd(Tcl_Interp *interp); MODULE_SCOPE int TclProcessGetAutopurge(void); MODULE_SCOPE void TclProcessSetAutopurge(int flag); +MODULE_SCOPE void TclReapPids(int numPids, Tcl_Pid *pidPtr); +MODULE_SCOPE Tcl_Pid TclpGetChildPid(int id); /* *---------------------------------------------------------------- diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h index 494d6f1..4770747 100644 --- a/generic/tclIntPlatDecls.h +++ b/generic/tclIntPlatDecls.h @@ -562,6 +562,8 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; #else # undef TclpGetPid # define TclpGetPid(pid) ((unsigned long) (pid)) +# undef TclpGetChildPid +# define TclpGetChildPid(id) ((Tcl_Pid) (id)) #endif #endif /* _TCLINTPLATDECLS */ diff --git a/generic/tclPipe.c b/generic/tclPipe.c index d6cd188..c98ee7e 100644 --- a/generic/tclPipe.c +++ b/generic/tclPipe.c @@ -247,6 +247,61 @@ Tcl_ReapDetachedProcs(void) /* *---------------------------------------------------------------------- * + * TclReapPids -- + * + * This function is similar to Tcl_ReapDetachedProcs but works on a + * subset of processes. + * + * Results: + * None. + * + * Side effects: + * Processes are waited on, so that they can be reaped by the system. + * + *---------------------------------------------------------------------- + */ + +void +TclReapPids( + int numPids, /* Number of pids to detach: gives size of + * array pointed to by pidPtr. */ + Tcl_Pid *pidPtr) /* Array of pids to detach. */ +{ + register Detached *detPtr; + Detached *nextPtr, *prevPtr; + int status; + Tcl_Pid pid; + int i; + + Tcl_MutexLock(&pipeMutex); + for (detPtr = detList, prevPtr = NULL; detPtr != NULL; ) { + pid = 0; + for (i = 0; i < numPids; i++) { + if (detPtr->pid == pidPtr[i]) { + pid = Tcl_WaitPid(detPtr->pid, &status, WNOHANG); + break; + } + } + if ((pid == 0) || ((pid == (Tcl_Pid) -1) && (errno != ECHILD))) { + prevPtr = detPtr; + detPtr = detPtr->nextPtr; + continue; + } + nextPtr = detPtr->nextPtr; + if (prevPtr == NULL) { + detList = detPtr->nextPtr; + } else { + prevPtr->nextPtr = detPtr->nextPtr; + } + ckfree(detPtr); + detPtr = nextPtr; + } + Tcl_MutexUnlock(&pipeMutex); +} + +/* + *---------------------------------------------------------------------- + * * TclCleanupChildren -- * * This is a utility function used to wait for child processes to exit, @@ -854,7 +909,9 @@ TclCreatePipeline( * arguments between the "|" characters. */ - Tcl_ReapDetachedProcs(); + if (TclProcessGetAutopurge()) { + Tcl_ReapDetachedProcs(); + } pidPtr = ckalloc(cmdCount * sizeof(Tcl_Pid)); curInFile = inputFile; diff --git a/generic/tclProcess.c b/generic/tclProcess.c index 23ba4de..2557067 100644 --- a/generic/tclProcess.c +++ b/generic/tclProcess.c @@ -123,8 +123,47 @@ ProcessPurgeObjCmd( return TCL_ERROR; } - /* TODO */ - return TCL_ERROR; + if (objc == 1) { + /* + * Purge all detached processes. + */ + + Tcl_ReapDetachedProcs(); + } else { + int result; + int numPids; + Tcl_Obj **pidObjs; + Tcl_Pid *pids; + int id; + int i; + + /* + * Get pids from argument. + */ + + result = Tcl_ListObjGetElements(interp, objv[1], &numPids, &pidObjs); + if (result != TCL_OK) { + return result; + } + pids = (Tcl_Pid *) TclStackAlloc(interp, numPids * sizeof(Tcl_Pid)); + for (i = 0; i < numPids; i++) { + result = Tcl_GetIntFromObj(interp, pidObjs[i], (int *) &id); + if (result != TCL_OK) { + TclStackFree(interp, (void *) pids); + return result; + } + pids[i] = TclpGetChildPid(id); + } + + /* + * Purge only provided processes. + */ + + TclReapPids(numPids, pids); + TclStackFree(interp, (void *) pids); + } + + return TCL_OK; } /*---------------------------------------------------------------------- @@ -138,7 +177,7 @@ ProcessPurgeObjCmd( * Returns a standard Tcl result. * * Side effects: - * None.TODO + * Alters detached process handling by Tcl_ReapDetachedProcs(). * *---------------------------------------------------------------------- */ diff --git a/unix/tclUnixPipe.c b/unix/tclUnixPipe.c index be7b4eb..3d8e680 100644 --- a/unix/tclUnixPipe.c +++ b/unix/tclUnixPipe.c @@ -986,7 +986,9 @@ PipeClose2Proc( */ Tcl_DetachPids(pipePtr->numPids, pipePtr->pidPtr); - Tcl_ReapDetachedProcs(); + if (TclProcessGetAutopurge()) { + Tcl_ReapDetachedProcs(); + } if (pipePtr->errorFile) { TclpCloseFile(pipePtr->errorFile); diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c index 4666deb..6dd2173 100644 --- a/win/tclWinPipe.c +++ b/win/tclWinPipe.c @@ -884,6 +884,44 @@ TclpGetPid( Tcl_MutexUnlock(&pipeMutex); return (unsigned long) -1; } + +/* + *-------------------------------------------------------------------------- + * + * TclpGetChildPid -- + * + * Given a process id of a child process, return the HANDLE for that + * child process. + * + * Results: + * Returns the HANDLE for the child process. If the id was not known + * by Tcl, either because the id was not created by Tcl or the child + * process has already been reaped, NULL is returned. + * + * Side effects: + * None. + * + *-------------------------------------------------------------------------- + */ + +Tcl_Pid +TclpGetChildPid( + int id) /* The process id of the child process. */ +{ + ProcInfo *infoPtr; + + PipeInit(); + + Tcl_MutexLock(&pipeMutex); + for (infoPtr = procList; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { + if (infoPtr->dwProcessId == (DWORD) id) { + Tcl_MutexUnlock(&pipeMutex); + return (Tcl_Pid) infoPtr->hProcess; + } + } + Tcl_MutexUnlock(&pipeMutex); + return (Tcl_Pid) NULL; +} /* *---------------------------------------------------------------------- @@ -1991,7 +2029,9 @@ PipeClose2Proc( */ Tcl_DetachPids(pipePtr->numPids, pipePtr->pidPtr); - Tcl_ReapDetachedProcs(); + if (TclProcessGetAutopurge()) { + Tcl_ReapDetachedProcs(); + } if (pipePtr->errorFile) { if (TclpCloseFile(pipePtr->errorFile) != 0) { -- cgit v0.12 From 8dd2373a08bd2ec8d5796041d0f8945d24a811c1 Mon Sep 17 00:00:00 2001 From: "f.bonnet" Date: Wed, 23 Aug 2017 18:31:56 +0000 Subject: Refactoring and preliminary implementation of tcl::process (list|status) --- generic/tclInt.h | 6 +- generic/tclIntPlatDecls.h | 2 - generic/tclPipe.c | 65 +------ generic/tclProcess.c | 455 ++++++++++++++++++++++++++++++++++++++-------- unix/tclUnixPipe.c | 4 +- win/tclWinPipe.c | 42 +---- 6 files changed, 383 insertions(+), 191 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index 3e99f91..dcdf2f6 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4026,10 +4026,8 @@ MODULE_SCOPE int TclFullFinalizationRequested(void); */ MODULE_SCOPE Tcl_Command TclInitProcessCmd(Tcl_Interp *interp); -MODULE_SCOPE int TclProcessGetAutopurge(void); -MODULE_SCOPE void TclProcessSetAutopurge(int flag); -MODULE_SCOPE void TclReapPids(int numPids, Tcl_Pid *pidPtr); -MODULE_SCOPE Tcl_Pid TclpGetChildPid(int id); +MODULE_SCOPE void TclProcessDetach(Tcl_Pid pid); +MODULE_SCOPE int TclProcessStatus(Tcl_Pid pid, int options); /* *---------------------------------------------------------------- diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h index 4770747..494d6f1 100644 --- a/generic/tclIntPlatDecls.h +++ b/generic/tclIntPlatDecls.h @@ -562,8 +562,6 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; #else # undef TclpGetPid # define TclpGetPid(pid) ((unsigned long) (pid)) -# undef TclpGetChildPid -# define TclpGetChildPid(id) ((Tcl_Pid) (id)) #endif #endif /* _TCLINTPLATDECLS */ diff --git a/generic/tclPipe.c b/generic/tclPipe.c index c98ee7e..e7c419d 100644 --- a/generic/tclPipe.c +++ b/generic/tclPipe.c @@ -192,6 +192,7 @@ Tcl_DetachPids( detPtr->pid = pidPtr[i]; detPtr->nextPtr = detList; detList = detPtr; + TclProcessDetach(pidPtr[i]); } Tcl_MutexUnlock(&pipeMutex); @@ -221,13 +222,10 @@ Tcl_ReapDetachedProcs(void) { register Detached *detPtr; Detached *nextPtr, *prevPtr; - int status; - Tcl_Pid pid; Tcl_MutexLock(&pipeMutex); for (detPtr = detList, prevPtr = NULL; detPtr != NULL; ) { - pid = Tcl_WaitPid(detPtr->pid, &status, WNOHANG); - if ((pid == 0) || ((pid == (Tcl_Pid) -1) && (errno != ECHILD))) { + if (!TclProcessStatus(detPtr->pid, WNOHANG)) { prevPtr = detPtr; detPtr = detPtr->nextPtr; continue; @@ -247,61 +245,6 @@ Tcl_ReapDetachedProcs(void) /* *---------------------------------------------------------------------- * - * TclReapPids -- - * - * This function is similar to Tcl_ReapDetachedProcs but works on a - * subset of processes. - * - * Results: - * None. - * - * Side effects: - * Processes are waited on, so that they can be reaped by the system. - * - *---------------------------------------------------------------------- - */ - -void -TclReapPids( - int numPids, /* Number of pids to detach: gives size of - * array pointed to by pidPtr. */ - Tcl_Pid *pidPtr) /* Array of pids to detach. */ -{ - register Detached *detPtr; - Detached *nextPtr, *prevPtr; - int status; - Tcl_Pid pid; - int i; - - Tcl_MutexLock(&pipeMutex); - for (detPtr = detList, prevPtr = NULL; detPtr != NULL; ) { - pid = 0; - for (i = 0; i < numPids; i++) { - if (detPtr->pid == pidPtr[i]) { - pid = Tcl_WaitPid(detPtr->pid, &status, WNOHANG); - break; - } - } - if ((pid == 0) || ((pid == (Tcl_Pid) -1) && (errno != ECHILD))) { - prevPtr = detPtr; - detPtr = detPtr->nextPtr; - continue; - } - nextPtr = detPtr->nextPtr; - if (prevPtr == NULL) { - detList = detPtr->nextPtr; - } else { - prevPtr->nextPtr = detPtr->nextPtr; - } - ckfree(detPtr); - detPtr = nextPtr; - } - Tcl_MutexUnlock(&pipeMutex); -} - -/* - *---------------------------------------------------------------------- - * * TclCleanupChildren -- * * This is a utility function used to wait for child processes to exit, @@ -909,9 +852,7 @@ TclCreatePipeline( * arguments between the "|" characters. */ - if (TclProcessGetAutopurge()) { - Tcl_ReapDetachedProcs(); - } + Tcl_ReapDetachedProcs(); pidPtr = ckalloc(cmdCount * sizeof(Tcl_Pid)); curInFile = inputFile; diff --git a/generic/tclProcess.c b/generic/tclProcess.c index 2557067..733b1d7 100644 --- a/generic/tclProcess.c +++ b/generic/tclProcess.c @@ -12,22 +12,45 @@ #include "tclInt.h" +/* + * Autopurge flag. Process-global because of the way Tcl manages child + * processes (see tclPipe.c). + */ + static int autopurge = 1; /* Autopurge flag. */ +/* + * Hash table that keeps track of all child process statuses. Keys are the + * child process ids, values are (ProcessInfo *). + */ + +typedef struct ProcessInfo { + Tcl_Pid pid; /*FRED TODO*/ + int resolvedPid; /*FRED TODO unused?*/ + Tcl_Obj *status; /*FRED TODO*/ + +} ProcessInfo; +static Tcl_HashTable statusTable; +static int statusTableInitialized = 0; /* 0 means not yet initialized. */ +TCL_DECLARE_MUTEX(statusMutex) + /* * Prototypes for functions defined later in this file: */ -static int ProcessListObjCmd(ClientData clientData, +static int GetProcessStatus(Tcl_Pid pid, int resolvedPid, + int options, Tcl_Obj **statusPtr); +static int PurgeProcessStatus(Tcl_HashEntry *entry); +static int ProcessListObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int ProcessStatusObjCmd(ClientData clientData, +static int ProcessStatusObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int ProcessPurgeObjCmd(ClientData clientData, +static int ProcessPurgeObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int ProcessAutopurgeObjCmd(ClientData clientData, +static int ProcessAutopurgeObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -42,7 +65,7 @@ static int ProcessAutopurgeObjCmd(ClientData clientData, * Returns a standard Tcl result. * * Side effects: - * None.TODO + * None.FRED TODO * *---------------------------------------------------------------------- */ @@ -50,18 +73,36 @@ static int ProcessAutopurgeObjCmd(ClientData clientData, static int ProcessListObjCmd( ClientData clientData, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ + Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { + Tcl_Obj *result; + Tcl_HashEntry *entry; + Tcl_HashSearch search; + ProcessInfo *info; + if (objc != 1) { Tcl_WrongNumArgs(interp, 1, objv, NULL); return TCL_ERROR; } - /* TODO */ - return TCL_ERROR; - } + /* + * Return the list of all chid process ids. + */ + + result = Tcl_NewListObj(0, NULL); + Tcl_MutexLock(&statusMutex); + for (entry = Tcl_FirstHashEntry(&statusTable, &search); entry != NULL; + entry = Tcl_NextHashEntry(&search)) { + info = (ProcessInfo *) Tcl_GetHashValue(entry); + Tcl_ListObjAppendElement(interp, result, + Tcl_NewIntObj(info->resolvedPid)); + } + Tcl_MutexUnlock(&statusMutex); + Tcl_SetObjResult(interp, result); + return TCL_OK; +} /*---------------------------------------------------------------------- * @@ -74,7 +115,7 @@ ProcessListObjCmd( * Returns a standard Tcl result. * * Side effects: - * None.TODO + * None.FRED TODO * *---------------------------------------------------------------------- */ @@ -82,18 +123,61 @@ ProcessListObjCmd( static int ProcessStatusObjCmd( ClientData clientData, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ + Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { + Tcl_Obj *result; + int options; + Tcl_HashEntry *entry; + Tcl_HashSearch search; + ProcessInfo *info; + if (objc < 1) { Tcl_WrongNumArgs(interp, 1, objv, "?switches? ?pids?"); return TCL_ERROR; } - /* TODO */ - return TCL_ERROR; - } + /* FRED TODO switches */ + options = WNOHANG; + + /* + * Return the list of all chid process statuses. + */ + + result = Tcl_NewDictObj(); + Tcl_MutexLock(&statusMutex); + for (entry = Tcl_FirstHashEntry(&statusTable, &search); entry != NULL; + entry = Tcl_NextHashEntry(&search)) { + info = (ProcessInfo *) Tcl_GetHashValue(entry); + if (autopurge) { + if (GetProcessStatus(info->pid, info->resolvedPid, options, + NULL)) { + /* + * Purge. + */ + + PurgeProcessStatus(entry); + Tcl_DeleteHashEntry(entry); + continue; + } + } else if (!info->status) { + /* + * Update status. + */ + + if (GetProcessStatus(info->pid, info->resolvedPid, options, + &info->status)) { + Tcl_IncrRefCount(info->status); + } + } + Tcl_DictObjPut(interp, result, Tcl_NewIntObj(info->resolvedPid), + info->status ? info->status : Tcl_NewObj()); + } + Tcl_MutexUnlock(&statusMutex); + Tcl_SetObjResult(interp, result); + return TCL_OK; +} /*---------------------------------------------------------------------- * @@ -106,7 +190,7 @@ ProcessStatusObjCmd( * Returns a standard Tcl result. * * Side effects: - * None.TODO + * None.FRED TODO * *---------------------------------------------------------------------- */ @@ -114,57 +198,65 @@ ProcessStatusObjCmd( static int ProcessPurgeObjCmd( ClientData clientData, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ + Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { + Tcl_HashEntry *entry; + Tcl_HashSearch search; + int numPids; + Tcl_Obj **pidObjs; + int result; + int i; + int pid; + if (objc != 1 && objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "?pids?"); return TCL_ERROR; } +//FRED TODO update status list first. + if (objc == 1) { /* - * Purge all detached processes. + * Purge all terminated processes. */ - - Tcl_ReapDetachedProcs(); - } else { - int result; - int numPids; - Tcl_Obj **pidObjs; - Tcl_Pid *pids; - int id; - int i; + Tcl_MutexLock(&statusMutex); + for (entry = Tcl_FirstHashEntry(&statusTable, &search); entry != NULL; + entry = Tcl_NextHashEntry(&search)) { + if (PurgeProcessStatus(entry)) { + Tcl_DeleteHashEntry(entry); + } + } + Tcl_MutexUnlock(&statusMutex); + } else { /* - * Get pids from argument. + * Purge only provided processes. */ result = Tcl_ListObjGetElements(interp, objv[1], &numPids, &pidObjs); if (result != TCL_OK) { return result; } - pids = (Tcl_Pid *) TclStackAlloc(interp, numPids * sizeof(Tcl_Pid)); + Tcl_MutexLock(&statusMutex); for (i = 0; i < numPids; i++) { - result = Tcl_GetIntFromObj(interp, pidObjs[i], (int *) &id); + result = Tcl_GetIntFromObj(interp, pidObjs[i], (int *) &pid); if (result != TCL_OK) { - TclStackFree(interp, (void *) pids); + Tcl_MutexUnlock(&statusMutex); return result; } - pids[i] = TclpGetChildPid(id); - } - /* - * Purge only provided processes. - */ - - TclReapPids(numPids, pids); - TclStackFree(interp, (void *) pids); + entry = Tcl_FindHashEntry(&statusTable, INT2PTR(pid)); + if (entry && PurgeProcessStatus(entry)) { + Tcl_DeleteHashEntry(entry); + } + } + Tcl_MutexUnlock(&statusMutex); } return TCL_OK; - } +} /*---------------------------------------------------------------------- * @@ -185,10 +277,10 @@ ProcessPurgeObjCmd( static int ProcessAutopurgeObjCmd( ClientData clientData, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ + Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ - { +{ if (objc != 1 && objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "?flag?"); return TCL_ERROR; @@ -205,14 +297,14 @@ ProcessAutopurgeObjCmd( return result; } - TclProcessSetAutopurge(flag); + autopurge = !!flag; } /* * Return current value. */ - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(TclProcessGetAutopurge())); + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(autopurge)); return TCL_OK; } @@ -246,53 +338,258 @@ TclInitProcessCmd( }; Tcl_Command processCmd; + if (statusTableInitialized == 0) { + Tcl_MutexLock(&statusMutex); + if (statusTableInitialized == 0) { + Tcl_InitHashTable(&statusTable, TCL_ONE_WORD_KEYS); + statusTableInitialized = 1; + } + Tcl_MutexUnlock(&statusMutex); + } + processCmd = TclMakeEnsemble(interp, "::tcl::process", processImplMap); Tcl_Export(interp, Tcl_FindNamespace(interp, "::tcl", NULL, 0), "process", 0); return processCmd; } -/* - *---------------------------------------------------------------------- - * - * TclProcessGetAutopurge -- - * - * This function queries the value of the autopurge flag. - * - * Results: - * The current boolean value of the autopurge flag. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ +/* FRED TODO */ +void +TclProcessDetach( + Tcl_Pid pid) +{ + int resolvedPid; + Tcl_HashEntry *entry; + int isNew; + ProcessInfo *info; + + resolvedPid = TclpGetPid(pid); + Tcl_MutexLock(&statusMutex); + entry = Tcl_CreateHashEntry(&statusTable, INT2PTR(resolvedPid), &isNew); + if (!isNew) { + /* + * Pid was reused, free old status and reuse structure. + */ + + info = (ProcessInfo *) Tcl_GetHashValue(entry); + if (info->status) { + Tcl_DecrRefCount(info->status); + } + } else { + /* + * Allocate new info structure. + */ + info = (ProcessInfo *) ckalloc(sizeof(ProcessInfo)); + Tcl_SetHashValue(entry, info); + } + + /* + * Initialize with an empty status. + */ + + info->pid = pid; + info->resolvedPid = resolvedPid; + info->status = NULL; + + Tcl_MutexUnlock(&statusMutex); +} + +/* FRED TODO */ int -TclProcessGetAutopurge(void) +TclProcessStatus( + Tcl_Pid pid, + int options) { - return autopurge; + int resolvedPid; + Tcl_HashEntry *entry; + ProcessInfo *info; + Tcl_Obj *status; + int isNew; + + /* + * We need to get the resolved pid before we wait on it as the windows + * implementation of Tcl_WaitPid deletes the information such that any + * following calls to TclpGetPid fail. + */ + + resolvedPid = TclpGetPid(pid); + + if (!GetProcessStatus(pid, resolvedPid, options, + (autopurge ? NULL /* unused */: &status))) { + /* + * Process still alive, or non child-related error. + */ + + return 0; + } + + if (autopurge) { + /* + * Child terminated, purge. + */ + + Tcl_MutexLock(&statusMutex); + entry = Tcl_FindHashEntry(&statusTable, INT2PTR(resolvedPid)); + if (entry) { + PurgeProcessStatus(entry); + Tcl_DeleteHashEntry(entry); + } + Tcl_MutexUnlock(&statusMutex); + + return 1; + } + + /* + * Store process status. + */ + + Tcl_MutexLock(&statusMutex); + entry = Tcl_CreateHashEntry(&statusTable, INT2PTR(resolvedPid), &isNew); + if (!isNew) { + info = (ProcessInfo *) Tcl_GetHashValue(entry); + if (info->status) { + /* + * Free old status object. + */ + + Tcl_DecrRefCount(info->status); + } + } else { + /* + * Allocate new info structure. + */ + + info = (ProcessInfo *) ckalloc(sizeof(ProcessInfo)); + info->pid = pid; + info->resolvedPid = resolvedPid; + Tcl_SetHashValue(entry, info); + } + + info->status = status; + Tcl_IncrRefCount(status); + Tcl_MutexUnlock(&statusMutex); + + return 1; } -/* - *---------------------------------------------------------------------- - * - * TclProcessSetAutopurge -- - * - * This function sets the value of the autopurge flag. - * - * Results: - * None. - * - * Side effects: - * Sets the autopurge static variable. - * - *---------------------------------------------------------------------- - */ +/* FRED TODO */ +int +GetProcessStatus( + Tcl_Pid pid, + int resolvedPid, + int options, + Tcl_Obj **statusPtr) +{ + int waitStatus; + Tcl_Obj *statusCodes[5]; + const char *msg; -void -TclProcessSetAutopurge( - int flag) /* New value for autopurge. */ + pid = Tcl_WaitPid(pid, &waitStatus, options); + if ((pid == 0) || ((pid == (Tcl_Pid) -1) && (errno != ECHILD))) { + /* + * Process still alive, or non child-related error. + */ + + return 0; + } + + if (!statusPtr) { + return 1; + } + + /* + * Get process status. + */ + + if (pid == (Tcl_Pid) -1) { + /* + * POSIX errName msg + */ + + statusCodes[0] = Tcl_NewStringObj("POSIX", -1); + statusCodes[1] = Tcl_NewStringObj(Tcl_ErrnoId(), -1); + msg = Tcl_ErrnoMsg(errno); + if (errno == ECHILD) { + /* + * This changeup in message suggested by Mark Diekhans to + * remind people that ECHILD errors can occur on some + * systems if SIGCHLD isn't in its default state. + */ + + msg = "child process lost (is SIGCHLD ignored or trapped?)"; + } + statusCodes[2] = Tcl_NewStringObj(msg, -1); + *statusPtr = Tcl_NewListObj(3, statusCodes); + } else if (WIFEXITED(waitStatus)) { + /* + * CHILDSTATUS pid code + * + * Child exited with a non-zero exit status. + */ + + statusCodes[0] = Tcl_NewStringObj("CHILDSTATUS", -1); + statusCodes[1] = Tcl_NewIntObj(resolvedPid); + statusCodes[2] = Tcl_NewIntObj(WEXITSTATUS(waitStatus)); + *statusPtr = Tcl_NewListObj(3, statusCodes); + } else if (WIFSIGNALED(waitStatus)) { + /* + * CHILDKILLED pid sigName msg + * + * Child killed because of a signal + */ + + statusCodes[0] = Tcl_NewStringObj("CHILDKILLED", -1); + statusCodes[1] = Tcl_NewIntObj(resolvedPid); + statusCodes[2] = Tcl_NewStringObj(Tcl_SignalId(WTERMSIG(waitStatus)), -1); + statusCodes[3] = Tcl_NewStringObj(Tcl_SignalMsg(WTERMSIG(waitStatus)), -1); + *statusPtr = Tcl_NewListObj(4, statusCodes); + } else if (WIFSTOPPED(waitStatus)) { + /* + * CHILDSUSP pid sigName msg + * + * Child suspended because of a signal + */ + + statusCodes[0] = Tcl_NewStringObj("CHILDSUSP", -1); + statusCodes[1] = Tcl_NewIntObj(resolvedPid); + statusCodes[2] = Tcl_NewStringObj(Tcl_SignalId(WSTOPSIG(waitStatus)), -1); + statusCodes[3] = Tcl_NewStringObj(Tcl_SignalMsg(WSTOPSIG(waitStatus)), -1); + *statusPtr = Tcl_NewListObj(4, statusCodes); + } else { + /* + * TCL OPERATION EXEC ODDWAITRESULT + * + * Child wait status didn't make sense. + */ + + statusCodes[0] = Tcl_NewStringObj("TCL", -1); + statusCodes[1] = Tcl_NewStringObj("OPERATION", -1); + statusCodes[2] = Tcl_NewStringObj("EXEC", -1); + statusCodes[3] = Tcl_NewStringObj("ODDWAITRESULT", -1); + statusCodes[4] = Tcl_NewIntObj(resolvedPid); + *statusPtr = Tcl_NewListObj(5, statusCodes); + } + + return 1; +} + +/* FRED TODO */ +int +PurgeProcessStatus( + Tcl_HashEntry *entry) { - autopurge = !!flag; + ProcessInfo *info; + + info = (ProcessInfo *) Tcl_GetHashValue(entry); + if (info->status) { + /* + * Process has ended, purge. + */ + + Tcl_DecrRefCount(info->status); + return 1; + } + + return 0; } diff --git a/unix/tclUnixPipe.c b/unix/tclUnixPipe.c index 3d8e680..be7b4eb 100644 --- a/unix/tclUnixPipe.c +++ b/unix/tclUnixPipe.c @@ -986,9 +986,7 @@ PipeClose2Proc( */ Tcl_DetachPids(pipePtr->numPids, pipePtr->pidPtr); - if (TclProcessGetAutopurge()) { - Tcl_ReapDetachedProcs(); - } + Tcl_ReapDetachedProcs(); if (pipePtr->errorFile) { TclpCloseFile(pipePtr->errorFile); diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c index 6dd2173..4666deb 100644 --- a/win/tclWinPipe.c +++ b/win/tclWinPipe.c @@ -884,44 +884,6 @@ TclpGetPid( Tcl_MutexUnlock(&pipeMutex); return (unsigned long) -1; } - -/* - *-------------------------------------------------------------------------- - * - * TclpGetChildPid -- - * - * Given a process id of a child process, return the HANDLE for that - * child process. - * - * Results: - * Returns the HANDLE for the child process. If the id was not known - * by Tcl, either because the id was not created by Tcl or the child - * process has already been reaped, NULL is returned. - * - * Side effects: - * None. - * - *-------------------------------------------------------------------------- - */ - -Tcl_Pid -TclpGetChildPid( - int id) /* The process id of the child process. */ -{ - ProcInfo *infoPtr; - - PipeInit(); - - Tcl_MutexLock(&pipeMutex); - for (infoPtr = procList; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { - if (infoPtr->dwProcessId == (DWORD) id) { - Tcl_MutexUnlock(&pipeMutex); - return (Tcl_Pid) infoPtr->hProcess; - } - } - Tcl_MutexUnlock(&pipeMutex); - return (Tcl_Pid) NULL; -} /* *---------------------------------------------------------------------- @@ -2029,9 +1991,7 @@ PipeClose2Proc( */ Tcl_DetachPids(pipePtr->numPids, pipePtr->pidPtr); - if (TclProcessGetAutopurge()) { - Tcl_ReapDetachedProcs(); - } + Tcl_ReapDetachedProcs(); if (pipePtr->errorFile) { if (TclpCloseFile(pipePtr->errorFile) != 0) { -- cgit v0.12 From 57aa77515aae5d66471140213b35e4ff50972b0e Mon Sep 17 00:00:00 2001 From: "f.bonnet" Date: Wed, 23 Aug 2017 19:51:02 +0000 Subject: Added switches and pid list support to tcl::process status --- generic/tclProcess.c | 159 ++++++++++++++++++++++++++++++++++++++------------- 1 file changed, 119 insertions(+), 40 deletions(-) diff --git a/generic/tclProcess.c b/generic/tclProcess.c index 733b1d7..99bb7e1 100644 --- a/generic/tclProcess.c +++ b/generic/tclProcess.c @@ -77,7 +77,7 @@ ProcessListObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_Obj *result; + Tcl_Obj *list; Tcl_HashEntry *entry; Tcl_HashSearch search; ProcessInfo *info; @@ -91,16 +91,16 @@ ProcessListObjCmd( * Return the list of all chid process ids. */ - result = Tcl_NewListObj(0, NULL); + list = Tcl_NewListObj(0, NULL); Tcl_MutexLock(&statusMutex); for (entry = Tcl_FirstHashEntry(&statusTable, &search); entry != NULL; entry = Tcl_NextHashEntry(&search)) { info = (ProcessInfo *) Tcl_GetHashValue(entry); - Tcl_ListObjAppendElement(interp, result, + Tcl_ListObjAppendElement(interp, list, Tcl_NewIntObj(info->resolvedPid)); } Tcl_MutexUnlock(&statusMutex); - Tcl_SetObjResult(interp, result); + Tcl_SetObjResult(interp, list); return TCL_OK; } @@ -127,55 +127,136 @@ ProcessStatusObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_Obj *result; - int options; + Tcl_Obj *dict; + int index, options = WNOHANG; Tcl_HashEntry *entry; Tcl_HashSearch search; ProcessInfo *info; + int numPids; + Tcl_Obj **pidObjs; + int result; + int i; + int pid; + Tcl_Obj *const *savedobjv = objv; + static const char *const switches[] = { + "-wait", "--", NULL + }; + enum switches { + STATUS_WAIT, STATUS_LAST + }; - if (objc < 1) { - Tcl_WrongNumArgs(interp, 1, objv, "?switches? ?pids?"); + while (objc > 1) { + if (TclGetString(objv[1])[0] != '-') { + break; + } + if (Tcl_GetIndexFromObj(interp, objv[1], switches, "switches", 0, + &index) != TCL_OK) { + return TCL_ERROR; + } + ++objv; --objc; + if (STATUS_WAIT == (enum switches) index) { + options = 0; + } else { + break; + } + } + + if (objc != 1 && objc != 2) { + Tcl_WrongNumArgs(interp, 1, savedobjv, "?switches? ?pids?"); return TCL_ERROR; } - /* FRED TODO switches */ - options = WNOHANG; + if (objc == 1) { + /* + * Return the list of all child process statuses. + */ - /* - * Return the list of all chid process statuses. - */ + dict = Tcl_NewDictObj(); + Tcl_MutexLock(&statusMutex); + for (entry = Tcl_FirstHashEntry(&statusTable, &search); entry != NULL; + entry = Tcl_NextHashEntry(&search)) { + info = (ProcessInfo *) Tcl_GetHashValue(entry); + if (autopurge) { + if (GetProcessStatus(info->pid, info->resolvedPid, options, + NULL)) { + /* + * Purge. + */ + + PurgeProcessStatus(entry); + Tcl_DeleteHashEntry(entry); + continue; + } + } else if (!info->status) { + /* + * Update status. + */ + + if (GetProcessStatus(info->pid, info->resolvedPid, options, + &info->status)) { + Tcl_IncrRefCount(info->status); + } + } + Tcl_DictObjPut(interp, dict, Tcl_NewIntObj(info->resolvedPid), + info->status ? info->status : Tcl_NewObj()); + } + Tcl_MutexUnlock(&statusMutex); + } else { + /* + * Only return statuses of provided processes. + */ + + result = Tcl_ListObjGetElements(interp, objv[1], &numPids, &pidObjs); + if (result != TCL_OK) { + return result; + } + dict = Tcl_NewDictObj(); + Tcl_MutexLock(&statusMutex); + for (i = 0; i < numPids; i++) { + result = Tcl_GetIntFromObj(interp, pidObjs[i], (int *) &pid); + if (result != TCL_OK) { + Tcl_MutexUnlock(&statusMutex); + Tcl_DecrRefCount(dict); + return result; + } - result = Tcl_NewDictObj(); - Tcl_MutexLock(&statusMutex); - for (entry = Tcl_FirstHashEntry(&statusTable, &search); entry != NULL; - entry = Tcl_NextHashEntry(&search)) { - info = (ProcessInfo *) Tcl_GetHashValue(entry); - if (autopurge) { - if (GetProcessStatus(info->pid, info->resolvedPid, options, - NULL)) { + entry = Tcl_FindHashEntry(&statusTable, INT2PTR(pid)); + if (!entry) { /* - * Purge. + * Skip unknown process. */ - - PurgeProcessStatus(entry); - Tcl_DeleteHashEntry(entry); + continue; } - } else if (!info->status) { - /* - * Update status. - */ - - if (GetProcessStatus(info->pid, info->resolvedPid, options, - &info->status)) { - Tcl_IncrRefCount(info->status); - } + + info = (ProcessInfo *) Tcl_GetHashValue(entry); + if (autopurge) { + if (GetProcessStatus(info->pid, info->resolvedPid, options, + NULL)) { + /* + * Purge. + */ + + PurgeProcessStatus(entry); + Tcl_DeleteHashEntry(entry); + continue; + } + } else if (!info->status) { + /* + * Update status. + */ + + if (GetProcessStatus(info->pid, info->resolvedPid, options, + &info->status)) { + Tcl_IncrRefCount(info->status); + } + } + Tcl_DictObjPut(interp, dict, Tcl_NewIntObj(info->resolvedPid), + info->status ? info->status : Tcl_NewObj()); } - Tcl_DictObjPut(interp, result, Tcl_NewIntObj(info->resolvedPid), - info->status ? info->status : Tcl_NewObj()); + Tcl_MutexUnlock(&statusMutex); } - Tcl_MutexUnlock(&statusMutex); - Tcl_SetObjResult(interp, result); + Tcl_SetObjResult(interp, dict); return TCL_OK; } @@ -215,8 +296,6 @@ ProcessPurgeObjCmd( return TCL_ERROR; } -//FRED TODO update status list first. - if (objc == 1) { /* * Purge all terminated processes. -- cgit v0.12 From 43c89a019c37b43637956e0b21b5788f784b1972 Mon Sep 17 00:00:00 2001 From: "f.bonnet" Date: Sun, 27 Aug 2017 11:05:45 +0000 Subject: Refactoring to support all processes and not just detached ones. --- generic/tclInt.h | 15 +- generic/tclPipe.c | 75 ++----- generic/tclProcess.c | 625 +++++++++++++++++++++++++++++---------------------- 3 files changed, 391 insertions(+), 324 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index dcdf2f6..c7a0a0d 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4025,9 +4025,20 @@ MODULE_SCOPE int TclFullFinalizationRequested(void); * TIP #462. */ +typedef enum TclProcessWaitStatus { + TCL_PROCESS_ERROR = -1, + TCL_PROCESS_UNCHANGED = 0, + TCL_PROCESS_EXITED = 1, + TCL_PROCESS_SIGNALED = 2, + TCL_PROCESS_STOPPED = 3, + TCL_PROCESS_UNKNOWN_STATUS = 4 +} TclProcessWaitStatus; + MODULE_SCOPE Tcl_Command TclInitProcessCmd(Tcl_Interp *interp); -MODULE_SCOPE void TclProcessDetach(Tcl_Pid pid); -MODULE_SCOPE int TclProcessStatus(Tcl_Pid pid, int options); +MODULE_SCOPE void TclProcessCreated(Tcl_Pid pid); +MODULE_SCOPE TclProcessWaitStatus TclProcessWait(Tcl_Pid pid, int options, + int *codePtr, Tcl_Obj **msgObjPtr, + Tcl_Obj **errorObjPtr); /* *---------------------------------------------------------------- diff --git a/generic/tclPipe.c b/generic/tclPipe.c index e7c419d..d20d8eb 100644 --- a/generic/tclPipe.c +++ b/generic/tclPipe.c @@ -192,7 +192,6 @@ Tcl_DetachPids( detPtr->pid = pidPtr[i]; detPtr->nextPtr = detList; detList = detPtr; - TclProcessDetach(pidPtr[i]); } Tcl_MutexUnlock(&pipeMutex); @@ -222,10 +221,13 @@ Tcl_ReapDetachedProcs(void) { register Detached *detPtr; Detached *nextPtr, *prevPtr; + int status, code; Tcl_MutexLock(&pipeMutex); for (detPtr = detList, prevPtr = NULL; detPtr != NULL; ) { - if (!TclProcessStatus(detPtr->pid, WNOHANG)) { + status = TclProcessWait(detPtr->pid, WNOHANG, &code, NULL, NULL); + if (status == TCL_PROCESS_UNCHANGED || (status == TCL_PROCESS_ERROR + && code != ECHILD)) { prevPtr = detPtr; detPtr = detPtr->nextPtr; continue; @@ -275,37 +277,18 @@ TclCleanupChildren( { int result = TCL_OK; int i, abnormalExit, anyErrorInfo; - Tcl_Pid pid; - int waitStatus; - const char *msg; - unsigned long resolvedPid; + TclProcessWaitStatus waitStatus; + int code; + Tcl_Obj *msg, *error; abnormalExit = 0; for (i = 0; i < numPids; i++) { - /* - * We need to get the resolved pid before we wait on it as the windows - * implementation of Tcl_WaitPid deletes the information such that any - * following calls to TclpGetPid fail. - */ - - resolvedPid = TclpGetPid(pidPtr[i]); - pid = Tcl_WaitPid(pidPtr[i], &waitStatus, 0); - if (pid == (Tcl_Pid) -1) { + waitStatus = TclProcessWait(pidPtr[i], 0, &code, &msg, &error); + if (waitStatus == TCL_PROCESS_ERROR) { result = TCL_ERROR; if (interp != NULL) { - msg = Tcl_PosixError(interp); - if (errno == ECHILD) { - /* - * This changeup in message suggested by Mark Diekhans to - * remind people that ECHILD errors can occur on some - * systems if SIGCHLD isn't in its default state. - */ - - msg = - "child process lost (is SIGCHLD ignored or trapped?)"; - } - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "error waiting for process to exit: %s", msg)); + Tcl_SetObjErrorCode(interp, error); + Tcl_SetObjResult(interp, msg); } continue; } @@ -317,38 +300,17 @@ TclCleanupChildren( * removed). */ - if (!WIFEXITED(waitStatus) || (WEXITSTATUS(waitStatus) != 0)) { - char msg1[TCL_INTEGER_SPACE], msg2[TCL_INTEGER_SPACE]; - + if (waitStatus != TCL_PROCESS_EXITED || code != 0) { result = TCL_ERROR; - sprintf(msg1, "%lu", resolvedPid); - if (WIFEXITED(waitStatus)) { + if (waitStatus == TCL_PROCESS_EXITED) { if (interp != NULL) { - sprintf(msg2, "%u", WEXITSTATUS(waitStatus)); - Tcl_SetErrorCode(interp, "CHILDSTATUS", msg1, msg2, NULL); + Tcl_SetObjErrorCode(interp, error); + Tcl_DecrRefCount(msg); } abnormalExit = 1; } else if (interp != NULL) { - const char *p; - - if (WIFSIGNALED(waitStatus)) { - p = Tcl_SignalMsg(WTERMSIG(waitStatus)); - Tcl_SetErrorCode(interp, "CHILDKILLED", msg1, - Tcl_SignalId(WTERMSIG(waitStatus)), p, NULL); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "child killed: %s\n", p)); - } else if (WIFSTOPPED(waitStatus)) { - p = Tcl_SignalMsg(WSTOPSIG(waitStatus)); - Tcl_SetErrorCode(interp, "CHILDSUSP", msg1, - Tcl_SignalId(WSTOPSIG(waitStatus)), p, NULL); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "child suspended: %s\n", p)); - } else { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "child wait status didn't make sense\n", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", - "ODDWAITRESULT", msg1, NULL); - } + Tcl_SetObjErrorCode(interp, error); + Tcl_SetObjResult(interp, msg); } } } @@ -380,7 +342,7 @@ TclCleanupChildren( Tcl_PosixError(interp))); } else if (count > 0) { anyErrorInfo = 1; - Tcl_SetObjResult(interp, objPtr); + Tcl_SetObjResult(interp, objPtr); result = TCL_ERROR; } else { Tcl_DecrRefCount(objPtr); @@ -928,6 +890,7 @@ TclCreatePipeline( pidPtr[numPids] = pid; numPids++; + TclProcessCreated(pid); /* * Close off our copies of file descriptors that were set up for this diff --git a/generic/tclProcess.c b/generic/tclProcess.c index 99bb7e1..87fc8bb 100644 --- a/generic/tclProcess.c +++ b/generic/tclProcess.c @@ -20,27 +20,36 @@ static int autopurge = 1; /* Autopurge flag. */ /* - * Hash table that keeps track of all child process statuses. Keys are the - * child process ids, values are (ProcessInfo *). + * Hash tables that keeps track of all child process statuses. Keys are the + * child process ids and resolved pids, values are (ProcessInfo *). */ typedef struct ProcessInfo { Tcl_Pid pid; /*FRED TODO*/ - int resolvedPid; /*FRED TODO unused?*/ - Tcl_Obj *status; /*FRED TODO*/ - + int resolvedPid; /*FRED TODO*/ + int purge; /*FRED TODO*/ + TclProcessWaitStatus status; + int code; /*FRED TODO*/ + Tcl_Obj *msg; /*FRED TODO*/ + Tcl_Obj *error; /*FRED TODO*/ } ProcessInfo; -static Tcl_HashTable statusTable; -static int statusTableInitialized = 0; /* 0 means not yet initialized. */ -TCL_DECLARE_MUTEX(statusMutex) +static Tcl_HashTable infoTablePerPid; +static Tcl_HashTable infoTablePerResolvedPid; +static int infoTablesInitialized = 0; /* 0 means not yet initialized. */ +TCL_DECLARE_MUTEX(infoTablesMutex) /* * Prototypes for functions defined later in this file: */ -static int GetProcessStatus(Tcl_Pid pid, int resolvedPid, - int options, Tcl_Obj **statusPtr); -static int PurgeProcessStatus(Tcl_HashEntry *entry); +static void InitProcessInfo(ProcessInfo *info, Tcl_Pid pid, + int resolvedPid); +static void FreeProcessInfo(ProcessInfo *info, int preserveObjs); +static int RefreshProcessInfo(ProcessInfo *info, int options); +static int WaitProcessStatus(Tcl_Pid pid, int resolvedPid, + int options, int *codePtr, Tcl_Obj **msgPtr, + Tcl_Obj **errorObjPtr); +static Tcl_Obj * BuildProcessStatusObj(ProcessInfo *info); static int ProcessListObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -54,6 +63,231 @@ static int ProcessAutopurgeObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +/* FRED TODO */ +void +InitProcessInfo( + ProcessInfo *info, + Tcl_Pid pid, + int resolvedPid) +{ + info->pid = pid; + info->resolvedPid = resolvedPid; + info->purge = 0; + info->status = TCL_PROCESS_UNCHANGED; + info->code = 0; + info->msg = NULL; + info->error = NULL; +} + +/* FRED TODO */ +void +FreeProcessInfo( + ProcessInfo *info, + int preserveObjs) +{ + if (!preserveObjs) { + if (info->msg) { + Tcl_DecrRefCount(info->msg); + } + if (info->error) { + Tcl_DecrRefCount(info->error); + } + } + ckfree(info); +} + +/* FRED TODO */ +int +RefreshProcessInfo( + ProcessInfo *info, + int options +) +{ + if (info->status == TCL_PROCESS_UNCHANGED) { + /* + * Refresh & store status. + */ + + info->status = WaitProcessStatus(info->pid, info->resolvedPid, + options, &info->code, &info->msg, &info->error); + if (info->msg) Tcl_IncrRefCount(info->msg); + if (info->error) Tcl_IncrRefCount(info->error); + return (info->status != TCL_PROCESS_UNCHANGED); + } else { + return 0; + } +} + +/* FRED TODO */ +int +WaitProcessStatus( + Tcl_Pid pid, + int resolvedPid, + int options, + int *codePtr, + Tcl_Obj **msgObjPtr, + Tcl_Obj **errorObjPtr) +{ + int waitStatus; + Tcl_Obj *errorStrings[5]; + const char *msg; + + pid = Tcl_WaitPid(pid, &waitStatus, options); + if ((pid == 0)) { + /* + * No change. + */ + + return TCL_PROCESS_UNCHANGED; + } + + /* + * Get process status. + */ + + if (pid == (Tcl_Pid) -1) { + /* + * POSIX errName msg + */ + + msg = Tcl_ErrnoMsg(errno); + if (errno == ECHILD) { + /* + * This changeup in message suggested by Mark Diekhans to + * remind people that ECHILD errors can occur on some + * systems if SIGCHLD isn't in its default state. + */ + + msg = "child process lost (is SIGCHLD ignored or trapped?)"; + } + if (codePtr) *codePtr = errno; + if (msgObjPtr) *msgObjPtr = Tcl_ObjPrintf( + "error waiting for process to exit: %s", msg); + if (errorObjPtr) { + errorStrings[0] = Tcl_NewStringObj("POSIX", -1); + errorStrings[1] = Tcl_NewStringObj(Tcl_ErrnoId(), -1); + errorStrings[2] = Tcl_NewStringObj(msg, -1); + *errorObjPtr = Tcl_NewListObj(3, errorStrings); + } + return TCL_PROCESS_ERROR; + } else if (WIFEXITED(waitStatus)) { + if (codePtr) *codePtr = WEXITSTATUS(waitStatus); + if (!WEXITSTATUS(waitStatus)) { + /* + * Normal exit. + */ + + if (msgObjPtr) *msgObjPtr = NULL; + if (errorObjPtr) *errorObjPtr = NULL; + } else { + /* + * CHILDSTATUS pid code + * + * Child exited with a non-zero exit status. + */ + + if (msgObjPtr) *msgObjPtr = Tcl_NewStringObj( + "child process exited abnormally", -1); + if (errorObjPtr) { + errorStrings[0] = Tcl_NewStringObj("CHILDSTATUS", -1); + errorStrings[1] = Tcl_NewIntObj(resolvedPid); + errorStrings[2] = Tcl_NewIntObj(WEXITSTATUS(waitStatus)); + *errorObjPtr = Tcl_NewListObj(3, errorStrings); + } + } + return TCL_PROCESS_EXITED; + } else if (WIFSIGNALED(waitStatus)) { + /* + * CHILDKILLED pid sigName msg + * + * Child killed because of a signal. + */ + + msg = Tcl_SignalMsg(WTERMSIG(waitStatus)); + if (codePtr) *codePtr = WTERMSIG(waitStatus); + if (msgObjPtr) *msgObjPtr = Tcl_ObjPrintf( + "child killed: %s", msg); + if (errorObjPtr) { + errorStrings[0] = Tcl_NewStringObj("CHILDKILLED", -1); + errorStrings[1] = Tcl_NewIntObj(resolvedPid); + errorStrings[2] = Tcl_NewStringObj(Tcl_SignalId(WTERMSIG(waitStatus)), -1); + errorStrings[3] = Tcl_NewStringObj(msg, -1); + *errorObjPtr = Tcl_NewListObj(4, errorStrings); + } + return TCL_PROCESS_SIGNALED; + } else if (WIFSTOPPED(waitStatus)) { + /* + * CHILDSUSP pid sigName msg + * + * Child suspended because of a signal. + */ + + msg = Tcl_SignalMsg(WSTOPSIG(waitStatus)); + if (codePtr) *codePtr = WSTOPSIG(waitStatus); + if (msgObjPtr) *msgObjPtr = Tcl_ObjPrintf( + "child suspended: %s", msg); + if (errorObjPtr) { + errorStrings[0] = Tcl_NewStringObj("CHILDSUSP", -1); + errorStrings[1] = Tcl_NewIntObj(resolvedPid); + errorStrings[2] = Tcl_NewStringObj(Tcl_SignalId(WSTOPSIG(waitStatus)), -1); + errorStrings[3] = Tcl_NewStringObj(msg, -1); + *errorObjPtr = Tcl_NewListObj(4, errorStrings); + } + return TCL_PROCESS_STOPPED; + } else { + /* + * TCL OPERATION EXEC ODDWAITRESULT + * + * Child wait status didn't make sense. + */ + + if (codePtr) *codePtr = waitStatus; + if (msgObjPtr) *msgObjPtr = Tcl_NewStringObj( + "child wait status didn't make sense\n", -1); + if (errorObjPtr) { + errorStrings[0] = Tcl_NewStringObj("TCL", -1); + errorStrings[1] = Tcl_NewStringObj("OPERATION", -1); + errorStrings[2] = Tcl_NewStringObj("EXEC", -1); + errorStrings[3] = Tcl_NewStringObj("ODDWAITRESULT", -1); + errorStrings[4] = Tcl_NewIntObj(resolvedPid); + *errorObjPtr = Tcl_NewListObj(5, errorStrings); + } + return TCL_PROCESS_UNKNOWN_STATUS; + } +} + +/* FRED TODO */ +Tcl_Obj * +BuildProcessStatusObj( + ProcessInfo *info) +{ + Tcl_Obj *resultObjs[3]; + + if (info->status == TCL_PROCESS_UNCHANGED) { + /* + * Process still running, return empty obj. + */ + + return Tcl_NewObj(); + } + if (info->status == TCL_PROCESS_EXITED && info->code == 0) { + /* + * Normal exit, return TCL_OK. + */ + + return Tcl_NewIntObj(TCL_OK); + } + + /* + * Abnormal exit, return {TCL_ERROR msg error} + */ + + resultObjs[0] = Tcl_NewIntObj(TCL_ERROR); + resultObjs[1] = info->msg; + resultObjs[2] = info->error; + return Tcl_NewListObj(3, resultObjs); +} + /*---------------------------------------------------------------------- * * ProcessListObjCmd -- @@ -92,14 +326,14 @@ ProcessListObjCmd( */ list = Tcl_NewListObj(0, NULL); - Tcl_MutexLock(&statusMutex); - for (entry = Tcl_FirstHashEntry(&statusTable, &search); entry != NULL; - entry = Tcl_NextHashEntry(&search)) { + Tcl_MutexLock(&infoTablesMutex); + for (entry = Tcl_FirstHashEntry(&infoTablePerResolvedPid, &search); + entry != NULL; entry = Tcl_NextHashEntry(&search)) { info = (ProcessInfo *) Tcl_GetHashValue(entry); Tcl_ListObjAppendElement(interp, list, Tcl_NewIntObj(info->resolvedPid)); } - Tcl_MutexUnlock(&statusMutex); + Tcl_MutexUnlock(&infoTablesMutex); Tcl_SetObjResult(interp, list); return TCL_OK; } @@ -172,35 +406,17 @@ ProcessStatusObjCmd( */ dict = Tcl_NewDictObj(); - Tcl_MutexLock(&statusMutex); - for (entry = Tcl_FirstHashEntry(&statusTable, &search); entry != NULL; - entry = Tcl_NextHashEntry(&search)) { + Tcl_MutexLock(&infoTablesMutex); + for (entry = Tcl_FirstHashEntry(&infoTablePerResolvedPid, &search); + entry != NULL; entry = Tcl_NextHashEntry(&search)) { info = (ProcessInfo *) Tcl_GetHashValue(entry); - if (autopurge) { - if (GetProcessStatus(info->pid, info->resolvedPid, options, - NULL)) { - /* - * Purge. - */ - - PurgeProcessStatus(entry); - Tcl_DeleteHashEntry(entry); - continue; - } - } else if (!info->status) { - /* - * Update status. - */ + RefreshProcessInfo(info, options); + // TODO purge etc. - if (GetProcessStatus(info->pid, info->resolvedPid, options, - &info->status)) { - Tcl_IncrRefCount(info->status); - } - } - Tcl_DictObjPut(interp, dict, Tcl_NewIntObj(info->resolvedPid), - info->status ? info->status : Tcl_NewObj()); + Tcl_DictObjPut(interp, dict, Tcl_NewIntObj(info->resolvedPid), + BuildProcessStatusObj(info)); } - Tcl_MutexUnlock(&statusMutex); + Tcl_MutexUnlock(&infoTablesMutex); } else { /* * Only return statuses of provided processes. @@ -211,16 +427,16 @@ ProcessStatusObjCmd( return result; } dict = Tcl_NewDictObj(); - Tcl_MutexLock(&statusMutex); + Tcl_MutexLock(&infoTablesMutex); for (i = 0; i < numPids; i++) { result = Tcl_GetIntFromObj(interp, pidObjs[i], (int *) &pid); if (result != TCL_OK) { - Tcl_MutexUnlock(&statusMutex); + Tcl_MutexUnlock(&infoTablesMutex); Tcl_DecrRefCount(dict); return result; } - entry = Tcl_FindHashEntry(&statusTable, INT2PTR(pid)); + entry = Tcl_FindHashEntry(&infoTablePerResolvedPid, INT2PTR(pid)); if (!entry) { /* * Skip unknown process. @@ -230,31 +446,14 @@ ProcessStatusObjCmd( } info = (ProcessInfo *) Tcl_GetHashValue(entry); - if (autopurge) { - if (GetProcessStatus(info->pid, info->resolvedPid, options, - NULL)) { - /* - * Purge. - */ - - PurgeProcessStatus(entry); - Tcl_DeleteHashEntry(entry); - continue; - } - } else if (!info->status) { - /* - * Update status. - */ + RefreshProcessInfo(info, options); - if (GetProcessStatus(info->pid, info->resolvedPid, options, - &info->status)) { - Tcl_IncrRefCount(info->status); - } - } - Tcl_DictObjPut(interp, dict, Tcl_NewIntObj(info->resolvedPid), - info->status ? info->status : Tcl_NewObj()); + // TODO purge etc. + + Tcl_DictObjPut(interp, dict, Tcl_NewIntObj(info->resolvedPid), + BuildProcessStatusObj(info)); } - Tcl_MutexUnlock(&statusMutex); + Tcl_MutexUnlock(&infoTablesMutex); } Tcl_SetObjResult(interp, dict); return TCL_OK; @@ -285,6 +484,7 @@ ProcessPurgeObjCmd( { Tcl_HashEntry *entry; Tcl_HashSearch search; + ProcessInfo *info; int numPids; Tcl_Obj **pidObjs; int result; @@ -301,14 +501,16 @@ ProcessPurgeObjCmd( * Purge all terminated processes. */ - Tcl_MutexLock(&statusMutex); - for (entry = Tcl_FirstHashEntry(&statusTable, &search); entry != NULL; + Tcl_MutexLock(&infoTablesMutex); + for (entry = Tcl_FirstHashEntry(&infoTablePerPid, &search); entry != NULL; entry = Tcl_NextHashEntry(&search)) { - if (PurgeProcessStatus(entry)) { + info = (ProcessInfo *) Tcl_GetHashValue(entry); + if (info->status != TCL_PROCESS_UNCHANGED) { Tcl_DeleteHashEntry(entry); + FreeProcessInfo(info, 0); } } - Tcl_MutexUnlock(&statusMutex); + Tcl_MutexUnlock(&infoTablesMutex); } else { /* * Purge only provided processes. @@ -318,20 +520,24 @@ ProcessPurgeObjCmd( if (result != TCL_OK) { return result; } - Tcl_MutexLock(&statusMutex); + Tcl_MutexLock(&infoTablesMutex); for (i = 0; i < numPids; i++) { result = Tcl_GetIntFromObj(interp, pidObjs[i], (int *) &pid); if (result != TCL_OK) { - Tcl_MutexUnlock(&statusMutex); + Tcl_MutexUnlock(&infoTablesMutex); return result; } - entry = Tcl_FindHashEntry(&statusTable, INT2PTR(pid)); - if (entry && PurgeProcessStatus(entry)) { - Tcl_DeleteHashEntry(entry); + entry = Tcl_FindHashEntry(&infoTablePerPid, INT2PTR(pid)); + if (entry) { + info = (ProcessInfo *) Tcl_GetHashValue(entry); + if (info->status != TCL_PROCESS_UNCHANGED) { + Tcl_DeleteHashEntry(entry); + FreeProcessInfo(info, 0); + } } } - Tcl_MutexUnlock(&statusMutex); + Tcl_MutexUnlock(&infoTablesMutex); } return TCL_OK; @@ -417,13 +623,14 @@ TclInitProcessCmd( }; Tcl_Command processCmd; - if (statusTableInitialized == 0) { - Tcl_MutexLock(&statusMutex); - if (statusTableInitialized == 0) { - Tcl_InitHashTable(&statusTable, TCL_ONE_WORD_KEYS); - statusTableInitialized = 1; + if (infoTablesInitialized == 0) { + Tcl_MutexLock(&infoTablesMutex); + if (infoTablesInitialized == 0) { + Tcl_InitHashTable(&infoTablePerPid, TCL_ONE_WORD_KEYS); + Tcl_InitHashTable(&infoTablePerResolvedPid, TCL_ONE_WORD_KEYS); + infoTablesInitialized = 1; } - Tcl_MutexUnlock(&statusMutex); + Tcl_MutexUnlock(&infoTablesMutex); } processCmd = TclMakeEnsemble(interp, "::tcl::process", processImplMap); @@ -434,7 +641,7 @@ TclInitProcessCmd( /* FRED TODO */ void -TclProcessDetach( +TclProcessCreated( Tcl_Pid pid) { int resolvedPid; @@ -442,233 +649,119 @@ TclProcessDetach( int isNew; ProcessInfo *info; + /* + * Get resolved pid first. + */ + resolvedPid = TclpGetPid(pid); - Tcl_MutexLock(&statusMutex); - entry = Tcl_CreateHashEntry(&statusTable, INT2PTR(resolvedPid), &isNew); + + Tcl_MutexLock(&infoTablesMutex); + + /* + * Create entry in pid table. + */ + + entry = Tcl_CreateHashEntry(&infoTablePerPid, pid, &isNew); if (!isNew) { /* - * Pid was reused, free old status and reuse structure. + * Pid was reused, free old info and reuse structure. */ info = (ProcessInfo *) Tcl_GetHashValue(entry); - if (info->status) { - Tcl_DecrRefCount(info->status); - } - } else { - /* - * Allocate new info structure. - */ - - info = (ProcessInfo *) ckalloc(sizeof(ProcessInfo)); - Tcl_SetHashValue(entry, info); + FreeProcessInfo(info, 0); } - + /* - * Initialize with an empty status. + * Allocate and initialize info structure. */ - info->pid = pid; - info->resolvedPid = resolvedPid; - info->status = NULL; + info = (ProcessInfo *) ckalloc(sizeof(ProcessInfo)); + InitProcessInfo(info, pid, resolvedPid); + + /* + * Add entry to tables. + */ - Tcl_MutexUnlock(&statusMutex); + Tcl_SetHashValue(entry, info); + entry = Tcl_CreateHashEntry(&infoTablePerResolvedPid, INT2PTR(resolvedPid), &isNew); + Tcl_SetHashValue(entry, info); + + Tcl_MutexUnlock(&infoTablesMutex); } + /* FRED TODO */ -int -TclProcessStatus( +TclProcessWaitStatus +TclProcessWait( Tcl_Pid pid, - int options) + int options, + int *codePtr, + Tcl_Obj **msgObjPtr, + Tcl_Obj **errorObjPtr) { - int resolvedPid; Tcl_HashEntry *entry; ProcessInfo *info; - Tcl_Obj *status; - int isNew; - + int result; + /* - * We need to get the resolved pid before we wait on it as the windows - * implementation of Tcl_WaitPid deletes the information such that any - * following calls to TclpGetPid fail. + * First search for pid in table. */ - resolvedPid = TclpGetPid(pid); - - if (!GetProcessStatus(pid, resolvedPid, options, - (autopurge ? NULL /* unused */: &status))) { + entry = Tcl_FindHashEntry(&infoTablePerPid, pid); + if (!entry) { /* - * Process still alive, or non child-related error. + * Unknown process, just call WaitProcessStatus and return. */ - return 0; - } - - if (autopurge) { - /* - * Child terminated, purge. - */ - - Tcl_MutexLock(&statusMutex); - entry = Tcl_FindHashEntry(&statusTable, INT2PTR(resolvedPid)); - if (entry) { - PurgeProcessStatus(entry); - Tcl_DeleteHashEntry(entry); - } - Tcl_MutexUnlock(&statusMutex); - - return 1; + return WaitProcessStatus(pid, TclpGetPid(pid), options, codePtr, + msgObjPtr, errorObjPtr); } - /* - * Store process status. - */ - - Tcl_MutexLock(&statusMutex); - entry = Tcl_CreateHashEntry(&statusTable, INT2PTR(resolvedPid), &isNew); - if (!isNew) { - info = (ProcessInfo *) Tcl_GetHashValue(entry); - if (info->status) { - /* - * Free old status object. - */ - - Tcl_DecrRefCount(info->status); - } - } else { + info = (ProcessInfo *) Tcl_GetHashValue(entry); + if (info->purge) { /* - * Allocate new info structure. + * Process has completed but TclProcessWait has already been called, + * so report no change. */ - - info = (ProcessInfo *) ckalloc(sizeof(ProcessInfo)); - info->pid = pid; - info->resolvedPid = resolvedPid; - Tcl_SetHashValue(entry, info); + + return TCL_PROCESS_UNCHANGED; } - info->status = status; - Tcl_IncrRefCount(status); - Tcl_MutexUnlock(&statusMutex); - - return 1; -} - -/* FRED TODO */ -int -GetProcessStatus( - Tcl_Pid pid, - int resolvedPid, - int options, - Tcl_Obj **statusPtr) -{ - int waitStatus; - Tcl_Obj *statusCodes[5]; - const char *msg; - - pid = Tcl_WaitPid(pid, &waitStatus, options); - if ((pid == 0) || ((pid == (Tcl_Pid) -1) && (errno != ECHILD))) { + RefreshProcessInfo(info, options); + if (info->status == TCL_PROCESS_UNCHANGED) { /* - * Process still alive, or non child-related error. + * No change, stop there. */ - return 0; - } - - if (!statusPtr) { - return 1; + return TCL_PROCESS_UNCHANGED; } /* - * Get process status. + * Set return values. */ - if (pid == (Tcl_Pid) -1) { - /* - * POSIX errName msg - */ + result = info->status; + if (codePtr) *codePtr = info->code; + if (msgObjPtr) *msgObjPtr = info->msg; + if (errorObjPtr) *errorObjPtr = info->error; - statusCodes[0] = Tcl_NewStringObj("POSIX", -1); - statusCodes[1] = Tcl_NewStringObj(Tcl_ErrnoId(), -1); - msg = Tcl_ErrnoMsg(errno); - if (errno == ECHILD) { - /* - * This changeup in message suggested by Mark Diekhans to - * remind people that ECHILD errors can occur on some - * systems if SIGCHLD isn't in its default state. - */ - - msg = "child process lost (is SIGCHLD ignored or trapped?)"; - } - statusCodes[2] = Tcl_NewStringObj(msg, -1); - *statusPtr = Tcl_NewListObj(3, statusCodes); - } else if (WIFEXITED(waitStatus)) { - /* - * CHILDSTATUS pid code - * - * Child exited with a non-zero exit status. - */ - - statusCodes[0] = Tcl_NewStringObj("CHILDSTATUS", -1); - statusCodes[1] = Tcl_NewIntObj(resolvedPid); - statusCodes[2] = Tcl_NewIntObj(WEXITSTATUS(waitStatus)); - *statusPtr = Tcl_NewListObj(3, statusCodes); - } else if (WIFSIGNALED(waitStatus)) { - /* - * CHILDKILLED pid sigName msg - * - * Child killed because of a signal - */ - - statusCodes[0] = Tcl_NewStringObj("CHILDKILLED", -1); - statusCodes[1] = Tcl_NewIntObj(resolvedPid); - statusCodes[2] = Tcl_NewStringObj(Tcl_SignalId(WTERMSIG(waitStatus)), -1); - statusCodes[3] = Tcl_NewStringObj(Tcl_SignalMsg(WTERMSIG(waitStatus)), -1); - *statusPtr = Tcl_NewListObj(4, statusCodes); - } else if (WIFSTOPPED(waitStatus)) { + if (autopurge) { /* - * CHILDSUSP pid sigName msg - * - * Child suspended because of a signal + * Purge now. */ - statusCodes[0] = Tcl_NewStringObj("CHILDSUSP", -1); - statusCodes[1] = Tcl_NewIntObj(resolvedPid); - statusCodes[2] = Tcl_NewStringObj(Tcl_SignalId(WSTOPSIG(waitStatus)), -1); - statusCodes[3] = Tcl_NewStringObj(Tcl_SignalMsg(WSTOPSIG(waitStatus)), -1); - *statusPtr = Tcl_NewListObj(4, statusCodes); + Tcl_DeleteHashEntry(entry); + entry = Tcl_FindHashEntry(&infoTablePerResolvedPid, + INT2PTR(info->resolvedPid)); + Tcl_DeleteHashEntry(entry); + FreeProcessInfo(info, 1); } else { /* - * TCL OPERATION EXEC ODDWAITRESULT - * - * Child wait status didn't make sense. - */ - - statusCodes[0] = Tcl_NewStringObj("TCL", -1); - statusCodes[1] = Tcl_NewStringObj("OPERATION", -1); - statusCodes[2] = Tcl_NewStringObj("EXEC", -1); - statusCodes[3] = Tcl_NewStringObj("ODDWAITRESULT", -1); - statusCodes[4] = Tcl_NewIntObj(resolvedPid); - *statusPtr = Tcl_NewListObj(5, statusCodes); - } - - return 1; -} - -/* FRED TODO */ -int -PurgeProcessStatus( - Tcl_HashEntry *entry) -{ - ProcessInfo *info; - - info = (ProcessInfo *) Tcl_GetHashValue(entry); - if (info->status) { - /* - * Process has ended, purge. + * Eventually purge. Subsequent calls will return + * TCL_PROCESS_UNCHANGED. */ - Tcl_DecrRefCount(info->status); - return 1; + info->purge = 1; } - - return 0; + return result; } -- cgit v0.12 From 935e991786520c81b01c7c2992568703d3d0746f Mon Sep 17 00:00:00 2001 From: "f.bonnet" Date: Sun, 27 Aug 2017 15:24:22 +0000 Subject: On Windows, Tcl_Pids now map to dwProcessId instead of hProcess because the system reuses handles of recently terminated processes. --- win/tclWinPipe.c | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c index 4666deb..ce132d1 100644 --- a/win/tclWinPipe.c +++ b/win/tclWinPipe.c @@ -876,7 +876,7 @@ TclpGetPid( Tcl_MutexLock(&pipeMutex); for (infoPtr = procList; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { - if (infoPtr->hProcess == (HANDLE) pid) { + if (infoPtr->dwProcessId == (DWORD) pid) { Tcl_MutexUnlock(&pipeMutex); return infoPtr->dwProcessId; } @@ -1187,7 +1187,7 @@ TclpCreateProcess( WaitForInputIdle(procInfo.hProcess, 5000); CloseHandle(procInfo.hThread); - *pidPtr = (Tcl_Pid) procInfo.hProcess; + *pidPtr = (Tcl_Pid) procInfo.dwProcessId; if (*pidPtr != 0) { TclWinAddProcess(procInfo.hProcess, procInfo.dwProcessId); } @@ -2458,7 +2458,7 @@ Tcl_WaitPid( prevPtrPtr = &procList; for (infoPtr = procList; infoPtr != NULL; prevPtrPtr = &infoPtr->nextPtr, infoPtr = infoPtr->nextPtr) { - if (infoPtr->hProcess == (HANDLE) pid) { + if (infoPtr->dwProcessId == (DWORD) pid) { *prevPtrPtr = infoPtr->nextPtr; break; } -- cgit v0.12 From 68b53cfb2571faea3e86f728b3a07222ea9143d0 Mon Sep 17 00:00:00 2001 From: "f.bonnet" Date: Sun, 27 Aug 2017 15:25:57 +0000 Subject: Fixed reference counting issue with objects returned by WaitProcessStatus --- generic/tclInt.h | 17 +++++--- generic/tclPipe.c | 5 ++- generic/tclProcess.c | 110 ++++++++++++++++++++++++++++++++++++--------------- 3 files changed, 93 insertions(+), 39 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index c7a0a0d..32b0d8a 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4025,13 +4025,18 @@ MODULE_SCOPE int TclFullFinalizationRequested(void); * TIP #462. */ +/* + * The following enum values give the status of a spawned process. + */ + typedef enum TclProcessWaitStatus { - TCL_PROCESS_ERROR = -1, - TCL_PROCESS_UNCHANGED = 0, - TCL_PROCESS_EXITED = 1, - TCL_PROCESS_SIGNALED = 2, - TCL_PROCESS_STOPPED = 3, - TCL_PROCESS_UNKNOWN_STATUS = 4 + TCL_PROCESS_ERROR = -1, /* Error waiting for process to exit */ + TCL_PROCESS_UNCHANGED = 0, /* No change since the last call. */ + TCL_PROCESS_EXITED = 1, /* Process has exited. */ + TCL_PROCESS_SIGNALED = 2, /* Child killed because of a signal. */ + TCL_PROCESS_STOPPED = 3, /* Child suspended because of a signal. */ + TCL_PROCESS_UNKNOWN_STATUS = 4 + /* Child wait status didn't make sense. */ } TclProcessWaitStatus; MODULE_SCOPE Tcl_Command TclInitProcessCmd(Tcl_Interp *interp); diff --git a/generic/tclPipe.c b/generic/tclPipe.c index d20d8eb..fa5c55d 100644 --- a/generic/tclPipe.c +++ b/generic/tclPipe.c @@ -290,6 +290,8 @@ TclCleanupChildren( Tcl_SetObjErrorCode(interp, error); Tcl_SetObjResult(interp, msg); } + Tcl_DecrRefCount(error); + Tcl_DecrRefCount(msg); continue; } @@ -305,7 +307,6 @@ TclCleanupChildren( if (waitStatus == TCL_PROCESS_EXITED) { if (interp != NULL) { Tcl_SetObjErrorCode(interp, error); - Tcl_DecrRefCount(msg); } abnormalExit = 1; } else if (interp != NULL) { @@ -313,6 +314,8 @@ TclCleanupChildren( Tcl_SetObjResult(interp, msg); } } + Tcl_DecrRefCount(error); + Tcl_DecrRefCount(msg); } /* diff --git a/generic/tclProcess.c b/generic/tclProcess.c index 87fc8bb..bd3467b 100644 --- a/generic/tclProcess.c +++ b/generic/tclProcess.c @@ -44,7 +44,7 @@ TCL_DECLARE_MUTEX(infoTablesMutex) static void InitProcessInfo(ProcessInfo *info, Tcl_Pid pid, int resolvedPid); -static void FreeProcessInfo(ProcessInfo *info, int preserveObjs); +static void FreeProcessInfo(ProcessInfo *info); static int RefreshProcessInfo(ProcessInfo *info, int options); static int WaitProcessStatus(Tcl_Pid pid, int resolvedPid, int options, int *codePtr, Tcl_Obj **msgPtr, @@ -82,16 +82,13 @@ InitProcessInfo( /* FRED TODO */ void FreeProcessInfo( - ProcessInfo *info, - int preserveObjs) + ProcessInfo *info) { - if (!preserveObjs) { - if (info->msg) { - Tcl_DecrRefCount(info->msg); - } - if (info->error) { - Tcl_DecrRefCount(info->error); - } + if (info->msg) { + Tcl_DecrRefCount(info->msg); + } + if (info->error) { + Tcl_DecrRefCount(info->error); } ckfree(info); } @@ -402,7 +399,7 @@ ProcessStatusObjCmd( if (objc == 1) { /* - * Return the list of all child process statuses. + * Return a dict with all child process statuses. */ dict = Tcl_NewDictObj(); @@ -411,10 +408,24 @@ ProcessStatusObjCmd( entry != NULL; entry = Tcl_NextHashEntry(&search)) { info = (ProcessInfo *) Tcl_GetHashValue(entry); RefreshProcessInfo(info, options); - // TODO purge etc. - Tcl_DictObjPut(interp, dict, Tcl_NewIntObj(info->resolvedPid), - BuildProcessStatusObj(info)); + if (info->purge && autopurge) { + /* + * Purge entry. + */ + + Tcl_DeleteHashEntry(entry); + entry = Tcl_FindHashEntry(&infoTablePerPid, info->pid); + Tcl_DeleteHashEntry(entry); + FreeProcessInfo(info); + } else { + /* + * Add to result. + */ + + Tcl_DictObjPut(interp, dict, Tcl_NewIntObj(info->resolvedPid), + BuildProcessStatusObj(info)); + } } Tcl_MutexUnlock(&infoTablesMutex); } else { @@ -448,10 +459,23 @@ ProcessStatusObjCmd( info = (ProcessInfo *) Tcl_GetHashValue(entry); RefreshProcessInfo(info, options); - // TODO purge etc. + if (info->purge && autopurge) { + /* + * Purge entry. + */ + + Tcl_DeleteHashEntry(entry); + entry = Tcl_FindHashEntry(&infoTablePerPid, info->pid); + Tcl_DeleteHashEntry(entry); + FreeProcessInfo(info); + } else { + /* + * Add to result. + */ - Tcl_DictObjPut(interp, dict, Tcl_NewIntObj(info->resolvedPid), - BuildProcessStatusObj(info)); + Tcl_DictObjPut(interp, dict, Tcl_NewIntObj(info->resolvedPid), + BuildProcessStatusObj(info)); + } } Tcl_MutexUnlock(&infoTablesMutex); } @@ -496,18 +520,26 @@ ProcessPurgeObjCmd( return TCL_ERROR; } + /* + * First reap detached procs so that their purge flag is up-to-date. + */ + + Tcl_ReapDetachedProcs(); + if (objc == 1) { /* * Purge all terminated processes. */ Tcl_MutexLock(&infoTablesMutex); - for (entry = Tcl_FirstHashEntry(&infoTablePerPid, &search); entry != NULL; - entry = Tcl_NextHashEntry(&search)) { + for (entry = Tcl_FirstHashEntry(&infoTablePerResolvedPid, &search); + entry != NULL; entry = Tcl_NextHashEntry(&search)) { info = (ProcessInfo *) Tcl_GetHashValue(entry); - if (info->status != TCL_PROCESS_UNCHANGED) { + if (info->purge) { + Tcl_DeleteHashEntry(entry); + entry = Tcl_FindHashEntry(&infoTablePerPid, info->pid); Tcl_DeleteHashEntry(entry); - FreeProcessInfo(info, 0); + FreeProcessInfo(info); } } Tcl_MutexUnlock(&infoTablesMutex); @@ -528,13 +560,21 @@ ProcessPurgeObjCmd( return result; } - entry = Tcl_FindHashEntry(&infoTablePerPid, INT2PTR(pid)); - if (entry) { - info = (ProcessInfo *) Tcl_GetHashValue(entry); - if (info->status != TCL_PROCESS_UNCHANGED) { - Tcl_DeleteHashEntry(entry); - FreeProcessInfo(info, 0); - } + entry = Tcl_FindHashEntry(&infoTablePerResolvedPid, INT2PTR(pid)); + if (!entry) { + /* + * Skip unknown process. + */ + + continue; + } + + info = (ProcessInfo *) Tcl_GetHashValue(entry); + if (info->purge) { + Tcl_DeleteHashEntry(entry); + entry = Tcl_FindHashEntry(&infoTablePerPid, info->pid); + Tcl_DeleteHashEntry(entry); + FreeProcessInfo(info); } } Tcl_MutexUnlock(&infoTablesMutex); @@ -668,7 +708,7 @@ TclProcessCreated( */ info = (ProcessInfo *) Tcl_GetHashValue(entry); - FreeProcessInfo(info, 0); + FreeProcessInfo(info); } /* @@ -683,7 +723,8 @@ TclProcessCreated( */ Tcl_SetHashValue(entry, info); - entry = Tcl_CreateHashEntry(&infoTablePerResolvedPid, INT2PTR(resolvedPid), &isNew); + entry = Tcl_CreateHashEntry(&infoTablePerResolvedPid, INT2PTR(resolvedPid), + &isNew); Tcl_SetHashValue(entry, info); Tcl_MutexUnlock(&infoTablesMutex); @@ -713,8 +754,11 @@ TclProcessWait( * Unknown process, just call WaitProcessStatus and return. */ - return WaitProcessStatus(pid, TclpGetPid(pid), options, codePtr, + result = WaitProcessStatus(pid, TclpGetPid(pid), options, codePtr, msgObjPtr, errorObjPtr); + if (msgObjPtr && *msgObjPtr) Tcl_IncrRefCount(*msgObjPtr); + if (errorObjPtr && *errorObjPtr) Tcl_IncrRefCount(*errorObjPtr); + return result; } info = (ProcessInfo *) Tcl_GetHashValue(entry); @@ -744,6 +788,8 @@ TclProcessWait( if (codePtr) *codePtr = info->code; if (msgObjPtr) *msgObjPtr = info->msg; if (errorObjPtr) *errorObjPtr = info->error; + if (msgObjPtr && *msgObjPtr) Tcl_IncrRefCount(*msgObjPtr); + if (errorObjPtr && *errorObjPtr) Tcl_IncrRefCount(*errorObjPtr); if (autopurge) { /* @@ -754,7 +800,7 @@ TclProcessWait( entry = Tcl_FindHashEntry(&infoTablePerResolvedPid, INT2PTR(info->resolvedPid)); Tcl_DeleteHashEntry(entry); - FreeProcessInfo(info, 1); + FreeProcessInfo(info); } else { /* * Eventually purge. Subsequent calls will return -- cgit v0.12 From 0a8718312d30c1e90db63395404caa10c890d9a4 Mon Sep 17 00:00:00 2001 From: "f.bonnet" Date: Sun, 27 Aug 2017 21:25:14 +0000 Subject: Comments and formatting --- generic/tclPipe.c | 2 +- generic/tclProcess.c | 923 +++++++++++++++++++++++++++++---------------------- 2 files changed, 532 insertions(+), 393 deletions(-) diff --git a/generic/tclPipe.c b/generic/tclPipe.c index fa5c55d..bc760b6 100644 --- a/generic/tclPipe.c +++ b/generic/tclPipe.c @@ -345,7 +345,7 @@ TclCleanupChildren( Tcl_PosixError(interp))); } else if (count > 0) { anyErrorInfo = 1; - Tcl_SetObjResult(interp, objPtr); + Tcl_SetObjResult(interp, objPtr); result = TCL_ERROR; } else { Tcl_DecrRefCount(objPtr); diff --git a/generic/tclProcess.c b/generic/tclProcess.c index bd3467b..8d98a23 100644 --- a/generic/tclProcess.c +++ b/generic/tclProcess.c @@ -2,7 +2,7 @@ * tclProcess.c -- * * This file implements the "tcl::process" ensemble for subprocess - * management as defined by TIP #462. + * management as defined by TIP #462. * * Copyright (c) 2017 Frederic Bonnet. * @@ -17,7 +17,7 @@ * processes (see tclPipe.c). */ -static int autopurge = 1; /* Autopurge flag. */ +static int autopurge = 1; /* Autopurge flag. */ /* * Hash tables that keeps track of all child process statuses. Keys are the @@ -25,13 +25,14 @@ static int autopurge = 1; /* Autopurge flag. */ */ typedef struct ProcessInfo { - Tcl_Pid pid; /*FRED TODO*/ - int resolvedPid; /*FRED TODO*/ - int purge; /*FRED TODO*/ - TclProcessWaitStatus status; - int code; /*FRED TODO*/ - Tcl_Obj *msg; /*FRED TODO*/ - Tcl_Obj *error; /*FRED TODO*/ + Tcl_Pid pid; /* Process id. */ + int resolvedPid; /* Resolved process id. */ + int purge; /* Purge eventualy. */ + TclProcessWaitStatus status;/* Process status. */ + int code; /* Error code, exit status or signal + number. */ + Tcl_Obj *msg; /* Error message. */ + Tcl_Obj *error; /* Error code. */ } ProcessInfo; static Tcl_HashTable infoTablePerPid; static Tcl_HashTable infoTablePerResolvedPid; @@ -42,33 +43,48 @@ TCL_DECLARE_MUTEX(infoTablesMutex) * Prototypes for functions defined later in this file: */ -static void InitProcessInfo(ProcessInfo *info, Tcl_Pid pid, - int resolvedPid); -static void FreeProcessInfo(ProcessInfo *info); -static int RefreshProcessInfo(ProcessInfo *info, int options); -static int WaitProcessStatus(Tcl_Pid pid, int resolvedPid, +static void InitProcessInfo(ProcessInfo *info, Tcl_Pid pid, + int resolvedPid); +static void FreeProcessInfo(ProcessInfo *info); +static int RefreshProcessInfo(ProcessInfo *info, int options); +static TclProcessWaitStatus WaitProcessStatus(Tcl_Pid pid, int resolvedPid, int options, int *codePtr, Tcl_Obj **msgPtr, - Tcl_Obj **errorObjPtr); -static Tcl_Obj * BuildProcessStatusObj(ProcessInfo *info); -static int ProcessListObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -static int ProcessStatusObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -static int ProcessPurgeObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -static int ProcessAutopurgeObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); - -/* FRED TODO */ + Tcl_Obj **errorObjPtr); +static Tcl_Obj * BuildProcessStatusObj(ProcessInfo *info); +static int ProcessListObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static int ProcessStatusObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static int ProcessPurgeObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static int ProcessAutopurgeObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); + +/* + *---------------------------------------------------------------------- + * + * InitProcessInfo -- + * + * Initializes the ProcessInfo structure. + * + * Results: + * None. + * + * Side effects: + * Memory written. + * + *---------------------------------------------------------------------- + */ + void InitProcessInfo( - ProcessInfo *info, - Tcl_Pid pid, - int resolvedPid) + ProcessInfo *info, /* Structure to initialize. */ + Tcl_Pid pid, /* Process id. */ + int resolvedPid) /* Resolved process id. */ { info->pid = pid; info->resolvedPid = resolvedPid; @@ -79,51 +95,115 @@ InitProcessInfo( info->error = NULL; } -/* FRED TODO */ +/* + *---------------------------------------------------------------------- + * + * FreeProcessInfo -- + * + * Free the ProcessInfo structure. + * + * Results: + * None. + * + * Side effects: + * Memory deallocated, Tcl_Obj refcount decreased. + * + *---------------------------------------------------------------------- + */ + void FreeProcessInfo( - ProcessInfo *info) + ProcessInfo *info) /* Structure to free. */ { + /* + * Free stored Tcl_Objs. + */ + if (info->msg) { - Tcl_DecrRefCount(info->msg); + Tcl_DecrRefCount(info->msg); } if (info->error) { - Tcl_DecrRefCount(info->error); + Tcl_DecrRefCount(info->error); } + + /* + * Free allocated structure. + */ + ckfree(info); } -/* FRED TODO */ +/* + *---------------------------------------------------------------------- + * + * RefreshProcessInfo -- + * + * Refresh process info. + * + * Results: + * Nonzero if state changed, else zero. + * + * Side effects: + * May call WaitProcessStatus, which can block if WNOHANG option is set. + * + *---------------------------------------------------------------------- + */ + int RefreshProcessInfo( - ProcessInfo *info, - int options + ProcessInfo *info, /* Structure to refresh. */ + int options /* Options passed to WaitProcessStatus. */ ) { if (info->status == TCL_PROCESS_UNCHANGED) { - /* - * Refresh & store status. - */ - - info->status = WaitProcessStatus(info->pid, info->resolvedPid, - options, &info->code, &info->msg, &info->error); - if (info->msg) Tcl_IncrRefCount(info->msg); - if (info->error) Tcl_IncrRefCount(info->error); - return (info->status != TCL_PROCESS_UNCHANGED); + /* + * Refresh & store status. + */ + + info->status = WaitProcessStatus(info->pid, info->resolvedPid, + options, &info->code, &info->msg, &info->error); + if (info->msg) Tcl_IncrRefCount(info->msg); + if (info->error) Tcl_IncrRefCount(info->error); + return (info->status != TCL_PROCESS_UNCHANGED); } else { - return 0; + /* + * No change. + */ + + return 0; } } -/* FRED TODO */ -int +/* + *---------------------------------------------------------------------- + * + * WaitProcessStatus -- + * + * Wait for process status to change. + * + * Results: + * TclProcessWaitStatus enum value. + * + * Side effects: + * May call WaitProcessStatus, which can block if WNOHANG option is set. + * + *---------------------------------------------------------------------- + */ + +TclProcessWaitStatus WaitProcessStatus( - Tcl_Pid pid, - int resolvedPid, - int options, - int *codePtr, - Tcl_Obj **msgObjPtr, - Tcl_Obj **errorObjPtr) + Tcl_Pid pid, /* Process id. */ + int resolvedPid, /* Resolved process id. */ + int options, /* Options passed to Tcl_WaitPid. */ + int *codePtr, /* If non-NULL, will receive either: + * - 0 for normal exit. + * - errno in case of error. + * - non-zero exit code for abormal exit. + * - signal number if killed or suspended. + * - Tcl_WaitPid status in all other cases. + */ + Tcl_Obj **msgObjPtr, /* If non-NULL, will receive error message. */ + Tcl_Obj **errorObjPtr) /* If non-NULL, will receive error code. */ { int waitStatus; Tcl_Obj *errorStrings[5]; @@ -131,11 +211,11 @@ WaitProcessStatus( pid = Tcl_WaitPid(pid, &waitStatus, options); if ((pid == 0)) { - /* - * No change. - */ - - return TCL_PROCESS_UNCHANGED; + /* + * No change. + */ + + return TCL_PROCESS_UNCHANGED; } /* @@ -143,117 +223,136 @@ WaitProcessStatus( */ if (pid == (Tcl_Pid) -1) { - /* - * POSIX errName msg - */ - - msg = Tcl_ErrnoMsg(errno); - if (errno == ECHILD) { - /* - * This changeup in message suggested by Mark Diekhans to - * remind people that ECHILD errors can occur on some - * systems if SIGCHLD isn't in its default state. - */ - - msg = "child process lost (is SIGCHLD ignored or trapped?)"; - } - if (codePtr) *codePtr = errno; - if (msgObjPtr) *msgObjPtr = Tcl_ObjPrintf( - "error waiting for process to exit: %s", msg); - if (errorObjPtr) { - errorStrings[0] = Tcl_NewStringObj("POSIX", -1); - errorStrings[1] = Tcl_NewStringObj(Tcl_ErrnoId(), -1); - errorStrings[2] = Tcl_NewStringObj(msg, -1); - *errorObjPtr = Tcl_NewListObj(3, errorStrings); - } - return TCL_PROCESS_ERROR; + /* + * POSIX errName msg + */ + + msg = Tcl_ErrnoMsg(errno); + if (errno == ECHILD) { + /* + * This changeup in message suggested by Mark Diekhans to + * remind people that ECHILD errors can occur on some + * systems if SIGCHLD isn't in its default state. + */ + + msg = "child process lost (is SIGCHLD ignored or trapped?)"; + } + if (codePtr) *codePtr = errno; + if (msgObjPtr) *msgObjPtr = Tcl_ObjPrintf( + "error waiting for process to exit: %s", msg); + if (errorObjPtr) { + errorStrings[0] = Tcl_NewStringObj("POSIX", -1); + errorStrings[1] = Tcl_NewStringObj(Tcl_ErrnoId(), -1); + errorStrings[2] = Tcl_NewStringObj(msg, -1); + *errorObjPtr = Tcl_NewListObj(3, errorStrings); + } + return TCL_PROCESS_ERROR; } else if (WIFEXITED(waitStatus)) { - if (codePtr) *codePtr = WEXITSTATUS(waitStatus); - if (!WEXITSTATUS(waitStatus)) { - /* - * Normal exit. - */ - - if (msgObjPtr) *msgObjPtr = NULL; - if (errorObjPtr) *errorObjPtr = NULL; - } else { - /* - * CHILDSTATUS pid code - * - * Child exited with a non-zero exit status. - */ - - if (msgObjPtr) *msgObjPtr = Tcl_NewStringObj( - "child process exited abnormally", -1); - if (errorObjPtr) { - errorStrings[0] = Tcl_NewStringObj("CHILDSTATUS", -1); - errorStrings[1] = Tcl_NewIntObj(resolvedPid); - errorStrings[2] = Tcl_NewIntObj(WEXITSTATUS(waitStatus)); - *errorObjPtr = Tcl_NewListObj(3, errorStrings); - } - } - return TCL_PROCESS_EXITED; + if (codePtr) *codePtr = WEXITSTATUS(waitStatus); + if (!WEXITSTATUS(waitStatus)) { + /* + * Normal exit. + */ + + if (msgObjPtr) *msgObjPtr = NULL; + if (errorObjPtr) *errorObjPtr = NULL; + } else { + /* + * CHILDSTATUS pid code + * + * Child exited with a non-zero exit status. + */ + + if (msgObjPtr) *msgObjPtr = Tcl_NewStringObj( + "child process exited abnormally", -1); + if (errorObjPtr) { + errorStrings[0] = Tcl_NewStringObj("CHILDSTATUS", -1); + errorStrings[1] = Tcl_NewIntObj(resolvedPid); + errorStrings[2] = Tcl_NewIntObj(WEXITSTATUS(waitStatus)); + *errorObjPtr = Tcl_NewListObj(3, errorStrings); + } + } + return TCL_PROCESS_EXITED; } else if (WIFSIGNALED(waitStatus)) { - /* - * CHILDKILLED pid sigName msg - * - * Child killed because of a signal. - */ - - msg = Tcl_SignalMsg(WTERMSIG(waitStatus)); - if (codePtr) *codePtr = WTERMSIG(waitStatus); - if (msgObjPtr) *msgObjPtr = Tcl_ObjPrintf( - "child killed: %s", msg); - if (errorObjPtr) { - errorStrings[0] = Tcl_NewStringObj("CHILDKILLED", -1); - errorStrings[1] = Tcl_NewIntObj(resolvedPid); - errorStrings[2] = Tcl_NewStringObj(Tcl_SignalId(WTERMSIG(waitStatus)), -1); - errorStrings[3] = Tcl_NewStringObj(msg, -1); - *errorObjPtr = Tcl_NewListObj(4, errorStrings); - } - return TCL_PROCESS_SIGNALED; + /* + * CHILDKILLED pid sigName msg + * + * Child killed because of a signal. + */ + + msg = Tcl_SignalMsg(WTERMSIG(waitStatus)); + if (codePtr) *codePtr = WTERMSIG(waitStatus); + if (msgObjPtr) *msgObjPtr = Tcl_ObjPrintf( + "child killed: %s", msg); + if (errorObjPtr) { + errorStrings[0] = Tcl_NewStringObj("CHILDKILLED", -1); + errorStrings[1] = Tcl_NewIntObj(resolvedPid); + errorStrings[2] = Tcl_NewStringObj(Tcl_SignalId(WTERMSIG(waitStatus)), -1); + errorStrings[3] = Tcl_NewStringObj(msg, -1); + *errorObjPtr = Tcl_NewListObj(4, errorStrings); + } + return TCL_PROCESS_SIGNALED; } else if (WIFSTOPPED(waitStatus)) { - /* - * CHILDSUSP pid sigName msg - * - * Child suspended because of a signal. - */ - - msg = Tcl_SignalMsg(WSTOPSIG(waitStatus)); - if (codePtr) *codePtr = WSTOPSIG(waitStatus); - if (msgObjPtr) *msgObjPtr = Tcl_ObjPrintf( - "child suspended: %s", msg); - if (errorObjPtr) { - errorStrings[0] = Tcl_NewStringObj("CHILDSUSP", -1); - errorStrings[1] = Tcl_NewIntObj(resolvedPid); - errorStrings[2] = Tcl_NewStringObj(Tcl_SignalId(WSTOPSIG(waitStatus)), -1); - errorStrings[3] = Tcl_NewStringObj(msg, -1); - *errorObjPtr = Tcl_NewListObj(4, errorStrings); - } - return TCL_PROCESS_STOPPED; + /* + * CHILDSUSP pid sigName msg + * + * Child suspended because of a signal. + */ + + msg = Tcl_SignalMsg(WSTOPSIG(waitStatus)); + if (codePtr) *codePtr = WSTOPSIG(waitStatus); + if (msgObjPtr) *msgObjPtr = Tcl_ObjPrintf( + "child suspended: %s", msg); + if (errorObjPtr) { + errorStrings[0] = Tcl_NewStringObj("CHILDSUSP", -1); + errorStrings[1] = Tcl_NewIntObj(resolvedPid); + errorStrings[2] = Tcl_NewStringObj(Tcl_SignalId(WSTOPSIG(waitStatus)), -1); + errorStrings[3] = Tcl_NewStringObj(msg, -1); + *errorObjPtr = Tcl_NewListObj(4, errorStrings); + } + return TCL_PROCESS_STOPPED; } else { - /* - * TCL OPERATION EXEC ODDWAITRESULT - * - * Child wait status didn't make sense. - */ - - if (codePtr) *codePtr = waitStatus; - if (msgObjPtr) *msgObjPtr = Tcl_NewStringObj( - "child wait status didn't make sense\n", -1); - if (errorObjPtr) { - errorStrings[0] = Tcl_NewStringObj("TCL", -1); - errorStrings[1] = Tcl_NewStringObj("OPERATION", -1); - errorStrings[2] = Tcl_NewStringObj("EXEC", -1); - errorStrings[3] = Tcl_NewStringObj("ODDWAITRESULT", -1); - errorStrings[4] = Tcl_NewIntObj(resolvedPid); - *errorObjPtr = Tcl_NewListObj(5, errorStrings); - } - return TCL_PROCESS_UNKNOWN_STATUS; + /* + * TCL OPERATION EXEC ODDWAITRESULT + * + * Child wait status didn't make sense. + */ + + if (codePtr) *codePtr = waitStatus; + if (msgObjPtr) *msgObjPtr = Tcl_NewStringObj( + "child wait status didn't make sense\n", -1); + if (errorObjPtr) { + errorStrings[0] = Tcl_NewStringObj("TCL", -1); + errorStrings[1] = Tcl_NewStringObj("OPERATION", -1); + errorStrings[2] = Tcl_NewStringObj("EXEC", -1); + errorStrings[3] = Tcl_NewStringObj("ODDWAITRESULT", -1); + errorStrings[4] = Tcl_NewIntObj(resolvedPid); + *errorObjPtr = Tcl_NewListObj(5, errorStrings); + } + return TCL_PROCESS_UNKNOWN_STATUS; } } -/* FRED TODO */ + +/* + *---------------------------------------------------------------------- + * + * BuildProcessStatusObj -- + * + * Build a list object with process status. The first element is always + * a standard Tcl return value, which can be either TCL_OK or TCL_ERROR. + * In the latter case, the second element is the error message and the + * third element is a Tcl error code (see tclvars). + * + * Results: + * A list object. + * + * Side effects: + * Tcl_Objs are created. + * + *---------------------------------------------------------------------- + */ + Tcl_Obj * BuildProcessStatusObj( ProcessInfo *info) @@ -261,18 +360,18 @@ BuildProcessStatusObj( Tcl_Obj *resultObjs[3]; if (info->status == TCL_PROCESS_UNCHANGED) { - /* - * Process still running, return empty obj. - */ + /* + * Process still running, return empty obj. + */ - return Tcl_NewObj(); + return Tcl_NewObj(); } if (info->status == TCL_PROCESS_EXITED && info->code == 0) { - /* - * Normal exit, return TCL_OK. - */ - - return Tcl_NewIntObj(TCL_OK); + /* + * Normal exit, return TCL_OK. + */ + + return Tcl_NewIntObj(TCL_OK); } /* @@ -290,13 +389,13 @@ BuildProcessStatusObj( * ProcessListObjCmd -- * * This function implements the 'tcl::process list' Tcl command. - * Refer to the user documentation for details on what it does. + * Refer to the user documentation for details on what it does. * * Results: * Returns a standard Tcl result. * * Side effects: - * None.FRED TODO + * Access to the internal structures is protected by infoTablesMutex. * *---------------------------------------------------------------------- */ @@ -325,10 +424,10 @@ ProcessListObjCmd( list = Tcl_NewListObj(0, NULL); Tcl_MutexLock(&infoTablesMutex); for (entry = Tcl_FirstHashEntry(&infoTablePerResolvedPid, &search); - entry != NULL; entry = Tcl_NextHashEntry(&search)) { - info = (ProcessInfo *) Tcl_GetHashValue(entry); - Tcl_ListObjAppendElement(interp, list, - Tcl_NewIntObj(info->resolvedPid)); + entry != NULL; entry = Tcl_NextHashEntry(&search)) { + info = (ProcessInfo *) Tcl_GetHashValue(entry); + Tcl_ListObjAppendElement(interp, list, + Tcl_NewIntObj(info->resolvedPid)); } Tcl_MutexUnlock(&infoTablesMutex); Tcl_SetObjResult(interp, list); @@ -340,13 +439,14 @@ ProcessListObjCmd( * ProcessStatusObjCmd -- * * This function implements the 'tcl::process status' Tcl command. - * Refer to the user documentation for details on what it does. + * Refer to the user documentation for details on what it does. * * Results: * Returns a standard Tcl result. * * Side effects: - * None.FRED TODO + * Access to the internal structures is protected by infoTablesMutex. + * Calls RefreshProcessInfo, which can block if -wait switch is given. * *---------------------------------------------------------------------- */ @@ -375,7 +475,7 @@ ProcessStatusObjCmd( enum switches { STATUS_WAIT, STATUS_LAST }; - + while (objc > 1) { if (TclGetString(objv[1])[0] != '-') { break; @@ -391,93 +491,93 @@ ProcessStatusObjCmd( break; } } - + if (objc != 1 && objc != 2) { Tcl_WrongNumArgs(interp, 1, savedobjv, "?switches? ?pids?"); return TCL_ERROR; } if (objc == 1) { - /* - * Return a dict with all child process statuses. - */ - - dict = Tcl_NewDictObj(); - Tcl_MutexLock(&infoTablesMutex); - for (entry = Tcl_FirstHashEntry(&infoTablePerResolvedPid, &search); - entry != NULL; entry = Tcl_NextHashEntry(&search)) { - info = (ProcessInfo *) Tcl_GetHashValue(entry); - RefreshProcessInfo(info, options); - - if (info->purge && autopurge) { - /* - * Purge entry. - */ - - Tcl_DeleteHashEntry(entry); - entry = Tcl_FindHashEntry(&infoTablePerPid, info->pid); - Tcl_DeleteHashEntry(entry); - FreeProcessInfo(info); - } else { - /* - * Add to result. - */ - - Tcl_DictObjPut(interp, dict, Tcl_NewIntObj(info->resolvedPid), - BuildProcessStatusObj(info)); - } - } - Tcl_MutexUnlock(&infoTablesMutex); + /* + * Return a dict with all child process statuses. + */ + + dict = Tcl_NewDictObj(); + Tcl_MutexLock(&infoTablesMutex); + for (entry = Tcl_FirstHashEntry(&infoTablePerResolvedPid, &search); + entry != NULL; entry = Tcl_NextHashEntry(&search)) { + info = (ProcessInfo *) Tcl_GetHashValue(entry); + RefreshProcessInfo(info, options); + + if (info->purge && autopurge) { + /* + * Purge entry. + */ + + Tcl_DeleteHashEntry(entry); + entry = Tcl_FindHashEntry(&infoTablePerPid, info->pid); + Tcl_DeleteHashEntry(entry); + FreeProcessInfo(info); + } else { + /* + * Add to result. + */ + + Tcl_DictObjPut(interp, dict, Tcl_NewIntObj(info->resolvedPid), + BuildProcessStatusObj(info)); + } + } + Tcl_MutexUnlock(&infoTablesMutex); } else { - /* - * Only return statuses of provided processes. - */ - - result = Tcl_ListObjGetElements(interp, objv[1], &numPids, &pidObjs); - if (result != TCL_OK) { - return result; - } - dict = Tcl_NewDictObj(); - Tcl_MutexLock(&infoTablesMutex); - for (i = 0; i < numPids; i++) { - result = Tcl_GetIntFromObj(interp, pidObjs[i], (int *) &pid); - if (result != TCL_OK) { - Tcl_MutexUnlock(&infoTablesMutex); - Tcl_DecrRefCount(dict); - return result; - } - - entry = Tcl_FindHashEntry(&infoTablePerResolvedPid, INT2PTR(pid)); - if (!entry) { - /* - * Skip unknown process. - */ - - continue; - } - - info = (ProcessInfo *) Tcl_GetHashValue(entry); - RefreshProcessInfo(info, options); - - if (info->purge && autopurge) { - /* - * Purge entry. - */ - - Tcl_DeleteHashEntry(entry); - entry = Tcl_FindHashEntry(&infoTablePerPid, info->pid); - Tcl_DeleteHashEntry(entry); - FreeProcessInfo(info); - } else { - /* - * Add to result. - */ - - Tcl_DictObjPut(interp, dict, Tcl_NewIntObj(info->resolvedPid), - BuildProcessStatusObj(info)); - } - } - Tcl_MutexUnlock(&infoTablesMutex); + /* + * Only return statuses of provided processes. + */ + + result = Tcl_ListObjGetElements(interp, objv[1], &numPids, &pidObjs); + if (result != TCL_OK) { + return result; + } + dict = Tcl_NewDictObj(); + Tcl_MutexLock(&infoTablesMutex); + for (i = 0; i < numPids; i++) { + result = Tcl_GetIntFromObj(interp, pidObjs[i], (int *) &pid); + if (result != TCL_OK) { + Tcl_MutexUnlock(&infoTablesMutex); + Tcl_DecrRefCount(dict); + return result; + } + + entry = Tcl_FindHashEntry(&infoTablePerResolvedPid, INT2PTR(pid)); + if (!entry) { + /* + * Skip unknown process. + */ + + continue; + } + + info = (ProcessInfo *) Tcl_GetHashValue(entry); + RefreshProcessInfo(info, options); + + if (info->purge && autopurge) { + /* + * Purge entry. + */ + + Tcl_DeleteHashEntry(entry); + entry = Tcl_FindHashEntry(&infoTablePerPid, info->pid); + Tcl_DeleteHashEntry(entry); + FreeProcessInfo(info); + } else { + /* + * Add to result. + */ + + Tcl_DictObjPut(interp, dict, Tcl_NewIntObj(info->resolvedPid), + BuildProcessStatusObj(info)); + } + } + Tcl_MutexUnlock(&infoTablesMutex); } Tcl_SetObjResult(interp, dict); return TCL_OK; @@ -488,13 +588,13 @@ ProcessStatusObjCmd( * ProcessPurgeObjCmd -- * * This function implements the 'tcl::process purge' Tcl command. - * Refer to the user documentation for details on what it does. + * Refer to the user documentation for details on what it does. * * Results: * Returns a standard Tcl result. * * Side effects: - * None.FRED TODO + * Frees all ProcessInfo structures with their purge flag set. * *---------------------------------------------------------------------- */ @@ -525,61 +625,61 @@ ProcessPurgeObjCmd( */ Tcl_ReapDetachedProcs(); - + if (objc == 1) { - /* - * Purge all terminated processes. - */ - - Tcl_MutexLock(&infoTablesMutex); - for (entry = Tcl_FirstHashEntry(&infoTablePerResolvedPid, &search); - entry != NULL; entry = Tcl_NextHashEntry(&search)) { - info = (ProcessInfo *) Tcl_GetHashValue(entry); - if (info->purge) { - Tcl_DeleteHashEntry(entry); - entry = Tcl_FindHashEntry(&infoTablePerPid, info->pid); - Tcl_DeleteHashEntry(entry); - FreeProcessInfo(info); - } - } - Tcl_MutexUnlock(&infoTablesMutex); + /* + * Purge all terminated processes. + */ + + Tcl_MutexLock(&infoTablesMutex); + for (entry = Tcl_FirstHashEntry(&infoTablePerResolvedPid, &search); + entry != NULL; entry = Tcl_NextHashEntry(&search)) { + info = (ProcessInfo *) Tcl_GetHashValue(entry); + if (info->purge) { + Tcl_DeleteHashEntry(entry); + entry = Tcl_FindHashEntry(&infoTablePerPid, info->pid); + Tcl_DeleteHashEntry(entry); + FreeProcessInfo(info); + } + } + Tcl_MutexUnlock(&infoTablesMutex); } else { - /* - * Purge only provided processes. - */ - - result = Tcl_ListObjGetElements(interp, objv[1], &numPids, &pidObjs); - if (result != TCL_OK) { - return result; - } - Tcl_MutexLock(&infoTablesMutex); - for (i = 0; i < numPids; i++) { - result = Tcl_GetIntFromObj(interp, pidObjs[i], (int *) &pid); - if (result != TCL_OK) { - Tcl_MutexUnlock(&infoTablesMutex); - return result; - } - - entry = Tcl_FindHashEntry(&infoTablePerResolvedPid, INT2PTR(pid)); - if (!entry) { - /* - * Skip unknown process. - */ - - continue; - } - - info = (ProcessInfo *) Tcl_GetHashValue(entry); - if (info->purge) { - Tcl_DeleteHashEntry(entry); - entry = Tcl_FindHashEntry(&infoTablePerPid, info->pid); - Tcl_DeleteHashEntry(entry); - FreeProcessInfo(info); - } - } - Tcl_MutexUnlock(&infoTablesMutex); + /* + * Purge only provided processes. + */ + + result = Tcl_ListObjGetElements(interp, objv[1], &numPids, &pidObjs); + if (result != TCL_OK) { + return result; + } + Tcl_MutexLock(&infoTablesMutex); + for (i = 0; i < numPids; i++) { + result = Tcl_GetIntFromObj(interp, pidObjs[i], (int *) &pid); + if (result != TCL_OK) { + Tcl_MutexUnlock(&infoTablesMutex); + return result; + } + + entry = Tcl_FindHashEntry(&infoTablePerResolvedPid, INT2PTR(pid)); + if (!entry) { + /* + * Skip unknown process. + */ + + continue; + } + + info = (ProcessInfo *) Tcl_GetHashValue(entry); + if (info->purge) { + Tcl_DeleteHashEntry(entry); + entry = Tcl_FindHashEntry(&infoTablePerPid, info->pid); + Tcl_DeleteHashEntry(entry); + FreeProcessInfo(info); + } + } + Tcl_MutexUnlock(&infoTablesMutex); } - + return TCL_OK; } @@ -588,7 +688,7 @@ ProcessPurgeObjCmd( * ProcessAutopurgeObjCmd -- * * This function implements the 'tcl::process autopurge' Tcl command. - * Refer to the user documentation for details on what it does. + * Refer to the user documentation for details on what it does. * * Results: * Returns a standard Tcl result. @@ -612,17 +712,17 @@ ProcessAutopurgeObjCmd( } if (objc == 2) { - /* - * Set given value. - */ - - int flag; - int result = Tcl_GetBooleanFromObj(interp, objv[1], &flag); - if (result != TCL_OK) { - return result; - } - - autopurge = !!flag; + /* + * Set given value. + */ + + int flag; + int result = Tcl_GetBooleanFromObj(interp, objv[1], &flag); + if (result != TCL_OK) { + return result; + } + + autopurge = !!flag; } /* @@ -655,11 +755,11 @@ TclInitProcessCmd( Tcl_Interp *interp) /* Current interpreter. */ { static const EnsembleImplMap processImplMap[] = { - {"list", ProcessListObjCmd, TclCompileBasic0ArgCmd, NULL, NULL, 1}, - {"status", ProcessStatusObjCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 1}, - {"purge", ProcessPurgeObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1}, - {"autopurge", ProcessAutopurgeObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1}, - {NULL, NULL, NULL, NULL, NULL, 0} + {"list", ProcessListObjCmd, TclCompileBasic0ArgCmd, NULL, NULL, 1}, + {"status", ProcessStatusObjCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 1}, + {"purge", ProcessPurgeObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1}, + {"autopurge", ProcessAutopurgeObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1}, + {NULL, NULL, NULL, NULL, NULL, 0} }; Tcl_Command processCmd; @@ -672,20 +772,35 @@ TclInitProcessCmd( } Tcl_MutexUnlock(&infoTablesMutex); } - + processCmd = TclMakeEnsemble(interp, "::tcl::process", processImplMap); Tcl_Export(interp, Tcl_FindNamespace(interp, "::tcl", NULL, 0), - "process", 0); + "process", 0); return processCmd; } -/* FRED TODO */ +/* + *---------------------------------------------------------------------- + * + * TclProcessCreated -- + * + * Called when a child process has been created by Tcl. + * + * Results: + * None. + * + * Side effects: + * Internal structures are updated with a new ProcessInfo. + * + *---------------------------------------------------------------------- + */ + void TclProcessCreated( - Tcl_Pid pid) + Tcl_Pid pid) /* Process id. */ { int resolvedPid; - Tcl_HashEntry *entry; + Tcl_HashEntry *entry, *entry2; int isNew; ProcessInfo *info; @@ -694,7 +809,7 @@ TclProcessCreated( */ resolvedPid = TclpGetPid(pid); - + Tcl_MutexLock(&infoTablesMutex); /* @@ -703,12 +818,15 @@ TclProcessCreated( entry = Tcl_CreateHashEntry(&infoTablePerPid, pid, &isNew); if (!isNew) { - /* - * Pid was reused, free old info and reuse structure. - */ - - info = (ProcessInfo *) Tcl_GetHashValue(entry); - FreeProcessInfo(info); + /* + * Pid was reused, free old info and reuse structure. + */ + + info = (ProcessInfo *) Tcl_GetHashValue(entry); + entry2 = Tcl_FindHashEntry(&infoTablePerResolvedPid, + INT2PTR(resolvedPid)); + if (entry2) Tcl_DeleteHashEntry(entry2); + FreeProcessInfo(info); } /* @@ -717,32 +835,53 @@ TclProcessCreated( info = (ProcessInfo *) ckalloc(sizeof(ProcessInfo)); InitProcessInfo(info, pid, resolvedPid); - + /* * Add entry to tables. */ Tcl_SetHashValue(entry, info); entry = Tcl_CreateHashEntry(&infoTablePerResolvedPid, INT2PTR(resolvedPid), - &isNew); + &isNew); Tcl_SetHashValue(entry, info); - + Tcl_MutexUnlock(&infoTablesMutex); } +/* + *---------------------------------------------------------------------- + * + * TclProcessWait -- + * + * Wait for process status to change. + * + * Results: + * TclProcessWaitStatus enum value. + * + * Side effects: + * Completed process info structures are purged immediately (autopurge on) + * or eventually (autopurge off). + * + *---------------------------------------------------------------------- + */ -/* FRED TODO */ TclProcessWaitStatus TclProcessWait( - Tcl_Pid pid, - int options, - int *codePtr, - Tcl_Obj **msgObjPtr, - Tcl_Obj **errorObjPtr) + Tcl_Pid pid, /* Process id. */ + int options, /* Options passed to WaitProcessStatus. */ + int *codePtr, /* If non-NULL, will receive either: + * - 0 for normal exit. + * - errno in case of error. + * - non-zero exit code for abormal exit. + * - signal number if killed or suspended. + * - Tcl_WaitPid status in all other cases. + */ + Tcl_Obj **msgObjPtr, /* If non-NULL, will receive error message. */ + Tcl_Obj **errorObjPtr) /* If non-NULL, will receive error code. */ { Tcl_HashEntry *entry; ProcessInfo *info; - int result; + TclProcessWaitStatus result; /* * First search for pid in table. @@ -750,34 +889,34 @@ TclProcessWait( entry = Tcl_FindHashEntry(&infoTablePerPid, pid); if (!entry) { - /* - * Unknown process, just call WaitProcessStatus and return. - */ - - result = WaitProcessStatus(pid, TclpGetPid(pid), options, codePtr, - msgObjPtr, errorObjPtr); - if (msgObjPtr && *msgObjPtr) Tcl_IncrRefCount(*msgObjPtr); - if (errorObjPtr && *errorObjPtr) Tcl_IncrRefCount(*errorObjPtr); - return result; + /* + * Unknown process, just call WaitProcessStatus and return. + */ + + result = WaitProcessStatus(pid, TclpGetPid(pid), options, codePtr, + msgObjPtr, errorObjPtr); + if (msgObjPtr && *msgObjPtr) Tcl_IncrRefCount(*msgObjPtr); + if (errorObjPtr && *errorObjPtr) Tcl_IncrRefCount(*errorObjPtr); + return result; } info = (ProcessInfo *) Tcl_GetHashValue(entry); if (info->purge) { - /* - * Process has completed but TclProcessWait has already been called, - * so report no change. - */ - - return TCL_PROCESS_UNCHANGED; + /* + * Process has completed but TclProcessWait has already been called, + * so report no change. + */ + + return TCL_PROCESS_UNCHANGED; } RefreshProcessInfo(info, options); if (info->status == TCL_PROCESS_UNCHANGED) { - /* - * No change, stop there. - */ - - return TCL_PROCESS_UNCHANGED; + /* + * No change, stop there. + */ + + return TCL_PROCESS_UNCHANGED; } /* @@ -792,22 +931,22 @@ TclProcessWait( if (errorObjPtr && *errorObjPtr) Tcl_IncrRefCount(*errorObjPtr); if (autopurge) { - /* - * Purge now. - */ - - Tcl_DeleteHashEntry(entry); - entry = Tcl_FindHashEntry(&infoTablePerResolvedPid, - INT2PTR(info->resolvedPid)); - Tcl_DeleteHashEntry(entry); - FreeProcessInfo(info); + /* + * Purge now. + */ + + Tcl_DeleteHashEntry(entry); + entry = Tcl_FindHashEntry(&infoTablePerResolvedPid, + INT2PTR(info->resolvedPid)); + Tcl_DeleteHashEntry(entry); + FreeProcessInfo(info); } else { - /* - * Eventually purge. Subsequent calls will return - * TCL_PROCESS_UNCHANGED. - */ + /* + * Eventually purge. Subsequent calls will return + * TCL_PROCESS_UNCHANGED. + */ - info->purge = 1; + info->purge = 1; } return result; } -- cgit v0.12 From 6fff25ecbcc670141c504a6dd0555d01204f761e Mon Sep 17 00:00:00 2001 From: "f.bonnet" Date: Sun, 5 Nov 2017 16:41:11 +0000 Subject: Fixed stupid Tcl_DecrRefCount bug in TclCleanupChildren with normally terminated processes. --- generic/tclPipe.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclPipe.c b/generic/tclPipe.c index bc760b6..13f4539 100644 --- a/generic/tclPipe.c +++ b/generic/tclPipe.c @@ -313,9 +313,9 @@ TclCleanupChildren( Tcl_SetObjErrorCode(interp, error); Tcl_SetObjResult(interp, msg); } + Tcl_DecrRefCount(error); + Tcl_DecrRefCount(msg); } - Tcl_DecrRefCount(error); - Tcl_DecrRefCount(msg); } /* -- cgit v0.12 From 3b5858bcd23542b0ff0249a128808ef20922beb6 Mon Sep 17 00:00:00 2001 From: oehhar Date: Wed, 10 Jan 2018 23:17:43 +0000 Subject: TIP490: oo for msgcal: new solution enable any command for oo, new command mcpackagenamespacege --- changes | 2 ++ library/msgcat/msgcat.tcl | 49 ++++++++++++++++++++++-------- library/msgcat/pkgIndex.tcl | 2 +- tests/msgcat.test | 74 +++++++++++++++++++++++++++++++++++++++++++++ unix/Makefile.in | 4 +-- win/Makefile.in | 4 +-- 6 files changed, 118 insertions(+), 17 deletions(-) diff --git a/changes b/changes index f89704b..51c0477 100644 --- a/changes +++ b/changes @@ -8879,3 +8879,5 @@ in this changeset (new minor version) rather than bug fixes: 2017-09-02 (bug)[0e4d88] replace command, delete trace kills namespace (porter) --- Released 8.7a1, September 8, 2017 --- http://core.tcl.tk/tcl/ for details + +2017-12-11 (TIP 490) add oo support for msgcat => msgcat 1.6.2 (oehlmann) diff --git a/library/msgcat/msgcat.tcl b/library/msgcat/msgcat.tcl index 646bc17..849adc6 100644 --- a/library/msgcat/msgcat.tcl +++ b/library/msgcat/msgcat.tcl @@ -14,12 +14,12 @@ package require Tcl 8.5- # When the version number changes, be sure to update the pkgIndex.tcl file, # and the installation directory in the Makefiles. -package provide msgcat 1.6.1 +package provide msgcat 1.6.2 namespace eval msgcat { namespace export mc mcexists mcload mclocale mcmax mcmset mcpreferences mcset\ mcunknown mcflset mcflmset mcloadedlocales mcforgetpackage\ - mcpackageconfig mcpackagelocale + mcpackagenamespaceget mcpackageconfig mcpackagelocale # Records the list of locales to search variable Loclist {} @@ -193,9 +193,6 @@ namespace eval msgcat { # format command. proc msgcat::mc {src args} { - # this may be replaced by: - # return [mcget -namespace [uplevel 1 [list ::namespace current]] --\ - # $src {*}$args] # Check for the src in each namespace starting from the local and # ending in the global. @@ -203,7 +200,7 @@ proc msgcat::mc {src args} { variable Msgs variable Loclist - set ns [uplevel 1 [list ::namespace current]] + set ns [PackageNamespaceGet] set loclist [PackagePreferences $ns] set nscur $ns @@ -245,7 +242,7 @@ proc msgcat::mcexists {args} { variable Loclist variable PackageConfig - set ns [uplevel 1 [list ::namespace current]] + set ns [PackageNamespaceGet] set loclist [PackagePreferences $ns] while {[llength $args] != 1} { @@ -462,7 +459,7 @@ proc msgcat::mcpackagelocale {subcommand {locale ""}} { } set locale [string tolower $locale] } - set ns [uplevel 1 {::namespace current}] + set ns [PackageNamespaceGet] switch -exact -- $subcommand { get { return [lindex [PackagePreferences $ns] 0] } @@ -551,7 +548,7 @@ proc msgcat::mcforgetpackage {} { # todo: this may be implemented using an ensemble variable PackageConfig variable Msgs - set ns [uplevel 1 {::namespace current}] + set ns [PackageNamespaceGet] # Remove MC items dict unset Msgs $ns # Remove config items @@ -561,6 +558,15 @@ proc msgcat::mcforgetpackage {} { return } +# msgcat::mcgetmynamespace -- +# +# Return the package namespace of the caller +# This consideres to be called from a class or object. + +proc msgcat::mcpackagenamespaceget {} { + return [PackageNamespaceGet] +} + # msgcat::mcpackageconfig -- # # Get or modify the per caller namespace (e.g. packages) config options. @@ -616,7 +622,7 @@ proc msgcat::mcforgetpackage {} { proc msgcat::mcpackageconfig {subcommand option {value ""}} { variable PackageConfig # get namespace - set ns [uplevel 1 {::namespace current}] + set ns [PackageNamespaceGet] if {$option ni {"mcfolder" "loadcmd" "changecmd" "unknowncmd"}} { return -code error "bad option \"$option\": must be mcfolder, loadcmd,\ @@ -923,7 +929,7 @@ proc msgcat::mcset {locale src {dest ""}} { set dest $src } - set ns [uplevel 1 [list ::namespace current]] + set ns [PackageNamespaceGet] set locale [string tolower $locale] @@ -975,7 +981,7 @@ proc msgcat::mcmset {locale pairs} { } set locale [string tolower $locale] - set ns [uplevel 1 [list ::namespace current]] + set ns [PackageNamespaceGet] foreach {src dest} $pairs { dict set Msgs $ns $locale $src $dest @@ -1106,6 +1112,25 @@ proc msgcat::ConvertLocale {value} { return $ret } +# helper function to find package namespace of stack-frame -2 +# There are 3 possibilities: +# - called from a proc +# - called from a oo class +# - called from a classless oo object +proc ::msgcat::PackageNamespaceGet {} { + uplevel 2 { + # Check for no object + if {0 == [llength [info commands self]]} {return [namespace current]} + set Class [info object class [self]] + # Check for classless defined object + if {$Class eq {::oo::object}} { + return [namespace qualifiers [self]] + } + # Class defined object + return [namespace qualifiers $Class] + } +} + # Initialize the default locale proc msgcat::Init {} { global env diff --git a/library/msgcat/pkgIndex.tcl b/library/msgcat/pkgIndex.tcl index 72c5dc0..bc58cbe 100644 --- a/library/msgcat/pkgIndex.tcl +++ b/library/msgcat/pkgIndex.tcl @@ -1,2 +1,2 @@ if {![package vsatisfies [package provide Tcl] 8.5-]} {return} -package ifneeded msgcat 1.6.1 [list source [file join $dir msgcat.tcl]] +package ifneeded msgcat 1.6.2 [list source [file join $dir msgcat.tcl]] diff --git a/tests/msgcat.test b/tests/msgcat.test index 1c3ce58..9dc8b48 100644 --- a/tests/msgcat.test +++ b/tests/msgcat.test @@ -1073,6 +1073,80 @@ namespace eval ::msgcat::test { } -returnCodes 1\ -result {fail} + + # Tests msgcat-15.*: tcloo coverage + + # There are 3 use-cases, where 2 must be tested now: + # - namespace defined, class defined oo, classless + + test msgcat-15.1 {mc in class} -setup { + namespace eval ::bar { + ::msgcat::mcset foo_BAR con2 con2bar + oo::class create ClassCur + oo::define ClassCur method method1 {} {::msgcat::mc con2} + } + namespace eval ::baz { + set ObjCur [::bar::ClassCur new] + } + variable locale [mclocale] + mclocale foo_BAR + } -cleanup { + mclocale $locale + namespace eval ::bar {::msgcat::mcforgetpackage} + namespace forget ::bar ::baz + } -body { + $::baz::ObjCur method1 + } -result con2bar + + test msgcat-15.2 {mc in classless object} -setup { + namespace eval ::bar { + ::msgcat::mcset foo_BAR con2 con2bar + oo::object create ObjCur + oo::objdefine ObjCur method method1 {} {::msgcat::mc con2} + } + variable locale [mclocale] + mclocale foo_BAR + } -cleanup { + mclocale $locale + namespace eval ::bar {::msgcat::mcforgetpackage} + namespace forget ::bar + } -body { + ::bar::ObjCur method1 + } -result con2bar + + # Test msgcat-16.*: command mcpackagenamespaceget + + test msgcat-16.1 {mcpackagenamespaceget in namespace procedure} -body { + namespace eval ::baz {msgcat::mcpackagenamespaceget} + } -result ::baz + + test msgcat-16.2 {mcpackagenamespaceget in class} -setup { + namespace eval ::bar { + oo::class create ClassCur + oo::define ClassCur method method1 {} {msgcat::mcpackagenamespaceget} + } + namespace eval ::baz { + set ObjCur [::bar::ClassCur new] + } + } -cleanup { + namespace forget ::bar ::baz + } -body { + $::baz::ObjCur method1 + } -result ::bar + + test msgcat-16.3 {mcpackagenamespaceget in classless object} -setup { + namespace eval ::bar { + oo::object create ObjCur + oo::objdefine ObjCur method method1 {} {msgcat::mcpackagenamespaceget} + } + } -cleanup { + namespace forget ::bar + } -body { + ::bar::ObjCur method1 + } -result ::bar + + + interp bgerror {} $bgerrorsaved cleanupTests diff --git a/unix/Makefile.in b/unix/Makefile.in index f3b9782..a343864 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -855,8 +855,8 @@ install-libraries: libraries do \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/opt0.4; \ done; - @echo "Installing package msgcat 1.6.1 as a Tcl Module"; - @$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/msgcat-1.6.1.tm; + @echo "Installing package msgcat 1.6.2 as a Tcl Module"; + @$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/msgcat-1.6.2.tm; @echo "Installing package tcltest 2.4.1 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.4.1.tm; diff --git a/win/Makefile.in b/win/Makefile.in index a3275ba..f3e1bd6 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -664,8 +664,8 @@ install-libraries: libraries install-tzdata install-msgs do \ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/opt0.4"; \ done; - @echo "Installing package msgcat 1.6.1 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/msgcat-1.6.1.tm; + @echo "Installing package msgcat 1.6.2 as a Tcl Module"; + @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/msgcat-1.6.2.tm; @echo "Installing package tcltest 2.4.0 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/tcltest-2.4.0.tm; @echo "Installing package platform 1.0.14 as a Tcl Module"; -- cgit v0.12 From 1fda13591a6eff53b73bfa288078edb56ab8a26c Mon Sep 17 00:00:00 2001 From: oehhar Date: Thu, 11 Jan 2018 16:46:09 +0000 Subject: Corrected test cleanups --- tests/msgcat.test | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/tests/msgcat.test b/tests/msgcat.test index 9dc8b48..387ce85 100644 --- a/tests/msgcat.test +++ b/tests/msgcat.test @@ -1093,7 +1093,7 @@ namespace eval ::msgcat::test { } -cleanup { mclocale $locale namespace eval ::bar {::msgcat::mcforgetpackage} - namespace forget ::bar ::baz + namespace delete ::bar ::baz } -body { $::baz::ObjCur method1 } -result con2bar @@ -1109,7 +1109,7 @@ namespace eval ::msgcat::test { } -cleanup { mclocale $locale namespace eval ::bar {::msgcat::mcforgetpackage} - namespace forget ::bar + namespace delete ::bar } -body { ::bar::ObjCur method1 } -result con2bar @@ -1129,7 +1129,7 @@ namespace eval ::msgcat::test { set ObjCur [::bar::ClassCur new] } } -cleanup { - namespace forget ::bar ::baz + namespace delete ::bar ::baz } -body { $::baz::ObjCur method1 } -result ::bar @@ -1140,7 +1140,7 @@ namespace eval ::msgcat::test { oo::objdefine ObjCur method method1 {} {msgcat::mcpackagenamespaceget} } } -cleanup { - namespace forget ::bar + namespace delete ::bar } -body { ::bar::ObjCur method1 } -result ::bar -- cgit v0.12 From e9f2695255b873c200a7fc465f860b4fd5c97a02 Mon Sep 17 00:00:00 2001 From: oehhar Date: Fri, 12 Jan 2018 14:03:04 +0000 Subject: replace "return [uplevel 1 [list [namespace origin ..." by tailcall --- library/msgcat/msgcat.tcl | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/library/msgcat/msgcat.tcl b/library/msgcat/msgcat.tcl index 849adc6..885240f 100644 --- a/library/msgcat/msgcat.tcl +++ b/library/msgcat/msgcat.tcl @@ -216,7 +216,7 @@ proc msgcat::mc {src args} { # call package local or default unknown command set args [linsert $args 0 [lindex $loclist 0] $src] switch -exact -- [Invoke unknowncmd $args $ns result 1] { - 0 { return [uplevel 1 [linsert $args 0 [namespace origin mcunknown]]] } + 0 { tailcall mcunknown {*}$args } 1 { return [DefaultUnknown {*}$args] } default { return $result } } @@ -762,8 +762,7 @@ proc msgcat::ListComplement {list1 list2 {inlistname ""}} { # Returns the number of message catalogs that were loaded. proc msgcat::mcload {langdir} { - return [uplevel 1 [list\ - [namespace origin mcpackageconfig] set mcfolder $langdir]] + tailcall mcpackageconfig set mcfolder $langdir } # msgcat::LoadAll -- @@ -957,7 +956,7 @@ proc msgcat::mcflset {src {dest ""}} { return -code error "must only be used inside a message catalog loaded\ with ::msgcat::mcload" } - return [uplevel 1 [list [namespace origin mcset] $FileLocale $src $dest]] + tailcall mcset $FileLocale $src $dest } # msgcat::mcmset -- @@ -1008,7 +1007,7 @@ proc msgcat::mcflmset {pairs} { return -code error "must only be used inside a message catalog loaded\ with ::msgcat::mcload" } - return [uplevel 1 [list [namespace origin mcmset] $FileLocale $pairs]] + tailcal mcmset $FileLocale $pairs } # msgcat::mcunknown -- @@ -1030,7 +1029,7 @@ proc msgcat::mcflmset {pairs} { # Returns the translated value. proc msgcat::mcunknown {args} { - return [uplevel 1 [list [namespace origin DefaultUnknown] {*}$args]] + tailcall DefaultUnknown {*}$args } # msgcat::DefaultUnknown -- -- cgit v0.12 From 2cfe8bb5619eb9a1de655bda6a208e9e2fb8b81b Mon Sep 17 00:00:00 2001 From: oehhar Date: Fri, 12 Jan 2018 14:13:03 +0000 Subject: Use the test "[namespace which self] ne "::oo::Helpers::self"" to check if we are within an object (undocumented test proposed by dkf on clt 2018-01-12 --- library/msgcat/msgcat.tcl | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/library/msgcat/msgcat.tcl b/library/msgcat/msgcat.tcl index 885240f..66cedea 100644 --- a/library/msgcat/msgcat.tcl +++ b/library/msgcat/msgcat.tcl @@ -1119,7 +1119,10 @@ proc msgcat::ConvertLocale {value} { proc ::msgcat::PackageNamespaceGet {} { uplevel 2 { # Check for no object - if {0 == [llength [info commands self]]} {return [namespace current]} + # (undocumented test proposed by dkf 2018-01-12) + if { [namespace which self] ne "::oo::Helpers::self"} { + return [namespace current] + } set Class [info object class [self]] # Check for classless defined object if {$Class eq {::oo::object}} { -- cgit v0.12 From e1ffd3f0057b68e75bce64f9c514b9993fb8a79c Mon Sep 17 00:00:00 2001 From: oehhar Date: Fri, 12 Jan 2018 14:52:25 +0000 Subject: Implement the "mcn" command as "mc" with explicit namespace. --- library/msgcat/msgcat.tcl | 32 ++++++++++++++++++++++++++++---- tests/msgcat.test | 12 ++++++++++++ 2 files changed, 40 insertions(+), 4 deletions(-) diff --git a/library/msgcat/msgcat.tcl b/library/msgcat/msgcat.tcl index 66cedea..29ccf0a 100644 --- a/library/msgcat/msgcat.tcl +++ b/library/msgcat/msgcat.tcl @@ -17,7 +17,8 @@ package require Tcl 8.5- package provide msgcat 1.6.2 namespace eval msgcat { - namespace export mc mcexists mcload mclocale mcmax mcmset mcpreferences mcset\ + namespace export mc mcn mcexists mcload mclocale mcmax\ + mcmset mcpreferences mcset\ mcunknown mcflset mcflmset mcloadedlocales mcforgetpackage\ mcpackagenamespaceget mcpackageconfig mcpackagelocale @@ -192,7 +193,30 @@ namespace eval msgcat { # Returns the translated string. Propagates errors thrown by the # format command. -proc msgcat::mc {src args} { +proc msgcat::mc {args} { + tailcall mcn [PackageNamespaceGet] {*}$args +} + +# msgcat::mcn -- +# +# Find the translation for the given string based on the current +# locale setting. Check the passed namespace first, then look in each +# parent namespace until the source is found. If additional args are +# specified, use the format command to work them into the traslated +# string. +# If no catalog item is found, mcunknown is called in the caller frame +# and its result is returned. +# +# Arguments: +# ns Package namespace of the translation +# src The string to translate. +# args Args to pass to the format command +# +# Results: +# Returns the translated string. Propagates errors thrown by the +# format command. + +proc msgcat::mcn {ns src args} { # Check for the src in each namespace starting from the local and # ending in the global. @@ -200,7 +224,6 @@ proc msgcat::mc {src args} { variable Msgs variable Loclist - set ns [PackageNamespaceGet] set loclist [PackagePreferences $ns] set nscur $ns @@ -1072,8 +1095,9 @@ proc msgcat::DefaultUnknown {locale src args} { proc msgcat::mcmax {args} { set max 0 + set ns [PackageNamespaceGet] foreach string $args { - set translated [uplevel 1 [list [namespace origin mc] $string]] + set translated [uplevel 1 [list [namespace origin mcn] $ns $string]] set len [string length $translated] if {$len>$max} { set max $len diff --git a/tests/msgcat.test b/tests/msgcat.test index 387ce85..c8f325b 100644 --- a/tests/msgcat.test +++ b/tests/msgcat.test @@ -1144,7 +1144,19 @@ namespace eval ::msgcat::test { } -body { ::bar::ObjCur method1 } -result ::bar + + + # Test msgcat-17.*: mcn command + test msgcat-17.1 {mcn} -setup { + namespace eval bar {::msgcat::mcset foo_BAR con1 con1bar} + variable locale [mclocale] + mclocale foo_BAR + } -cleanup { + mclocale $locale + } -body { + ::msgcat::mcn [namespace current]::bar con1 + } -result con1bar interp bgerror {} $bgerrorsaved -- cgit v0.12 From ecaec63f48c02c5bb7c0e7585ebc1d746b77ffd9 Mon Sep 17 00:00:00 2001 From: oehhar Date: Sat, 13 Jan 2018 15:23:38 +0000 Subject: Extended command msgcat::mcexists by switch "-namespace ns" to explicitly specify namespace --- library/msgcat/msgcat.tcl | 22 ++++++--- tests/msgcat.test | 120 ++++++++++++++++++++++++++++++++++++---------- 2 files changed, 109 insertions(+), 33 deletions(-) diff --git a/library/msgcat/msgcat.tcl b/library/msgcat/msgcat.tcl index 29ccf0a..e57802b 100644 --- a/library/msgcat/msgcat.tcl +++ b/library/msgcat/msgcat.tcl @@ -265,23 +265,31 @@ proc msgcat::mcexists {args} { variable Loclist variable PackageConfig - set ns [PackageNamespaceGet] - set loclist [PackagePreferences $ns] - while {[llength $args] != 1} { set args [lassign $args option] switch -glob -- $option { - -exactnamespace { set exactnamespace 1 } - -exactlocale { set loclist [lrange $loclist 0 0] } + -exactnamespace - -exactlocale { set $option 1 } + -namespace { + if {[llength $args] < 2} { + return -code error\ + "Argument missing for switch \"-namespace\"" + } + set args [lassign $args ns] + } -* { return -code error "unknown option \"$option\"" } default { return -code error "wrong # args: should be\ \"[lindex [info level 0] 0] ?-exactnamespace?\ - ?-exactlocale? src\"" + ?-exactlocale? ?-namespace ns? src\"" } } } set src [lindex $args 0] + + if {![info exists ns]} { set ns [PackageNamespaceGet] } + + set loclist [PackagePreferences $ns] + if {[info exists -exactlocale]} { set loclist [lrange $loclist 0 0] } while {$ns ne ""} { foreach loc $loclist { @@ -289,7 +297,7 @@ proc msgcat::mcexists {args} { return 1 } } - if {[info exists exactnamespace]} {return 0} + if {[info exists -exactnamespace]} {return 0} set ns [namespace parent $ns] } return 0 diff --git a/tests/msgcat.test b/tests/msgcat.test index c8f325b..a99086d 100644 --- a/tests/msgcat.test +++ b/tests/msgcat.test @@ -688,7 +688,7 @@ namespace eval ::msgcat::test { test msgcat-9.1 {mcexists no parameter} -body { mcexists } -returnCodes 1\ - -result {wrong # args: should be "mcexists ?-exactnamespace? ?-exactlocale? src"} + -result {wrong # args: should be "mcexists ?-exactnamespace? ?-exactlocale? ?-namespace ns? src"} test msgcat-9.2 {mcexists unknown option} -body { mcexists -unknown src @@ -724,12 +724,34 @@ namespace eval ::msgcat::test { mcset foo k1 v1 } -cleanup { mclocale $locale + namespace delete ::foo } -body { - namespace eval ::msgcat::test::sub { + namespace eval ::foo { list [::msgcat::mcexists k1]\ - [::msgcat::mcexists -exactnamespace k1] + [::msgcat::mcexists -namespace ::msgcat::test k1] } - } -result {1 0} + } -result {0 1} + + test msgcat-9.6 {mcexists -namespace - ns argument missing} -setup { + mcforgetpackage + variable locale [mclocale] + mclocale foo_bar + mcset foo k1 v1 + } -cleanup { + mclocale $locale + namespace delete ::foo + } -body { + namespace eval ::foo { + list [::msgcat::mcexists k1]\ + [::msgcat::mcexists -namespace ::msgcat::test k1] + } + } -result {0 1} + + test msgcat-9.1 {mcexists -namespace with no parameter} -body { + mcexists -namespace src + } -returnCodes 1\ + -result {Argument missing for switch "-namespace"} + # Tests msgcat-10.*: [mcloadedlocales] @@ -1080,26 +1102,29 @@ namespace eval ::msgcat::test { # - namespace defined, class defined oo, classless test msgcat-15.1 {mc in class} -setup { - namespace eval ::bar { + # full namespace is ::msgcat::test:bar + namespace eval bar { ::msgcat::mcset foo_BAR con2 con2bar oo::class create ClassCur oo::define ClassCur method method1 {} {::msgcat::mc con2} } - namespace eval ::baz { - set ObjCur [::bar::ClassCur new] + # full namespace is ::msgcat::test:baz + namespace eval baz { + set ObjCur [::msgcat::test::bar::ClassCur new] } variable locale [mclocale] mclocale foo_BAR } -cleanup { mclocale $locale - namespace eval ::bar {::msgcat::mcforgetpackage} - namespace delete ::bar ::baz + namespace eval bar {::msgcat::mcforgetpackage} + namespace delete bar baz } -body { - $::baz::ObjCur method1 + $baz::ObjCur method1 } -result con2bar test msgcat-15.2 {mc in classless object} -setup { - namespace eval ::bar { + # full namespace is ::msgcat::test:bar + namespace eval bar { ::msgcat::mcset foo_BAR con2 con2bar oo::object create ObjCur oo::objdefine ObjCur method method1 {} {::msgcat::mc con2} @@ -1108,42 +1133,85 @@ namespace eval ::msgcat::test { mclocale foo_BAR } -cleanup { mclocale $locale - namespace eval ::bar {::msgcat::mcforgetpackage} - namespace delete ::bar + namespace eval bar {::msgcat::mcforgetpackage} + namespace delete bar } -body { - ::bar::ObjCur method1 + bar::ObjCur method1 } -result con2bar + test msgcat-15.3 {mc in classless object with explicite namespace eval}\ + -setup { + # full namespace is ::msgcat::test:bar + namespace eval bar { + ::msgcat::mcset foo_BAR con2 con2bar + oo::object create ObjCur + oo::objdefine ObjCur method method1 {} { + namespace eval ::msgcat::test::baz { + ::msgcat::mc con2 + } + } + } + namespace eval baz { + ::msgcat::mcset foo_BAR con2 con2baz + } + variable locale [mclocale] + mclocale foo_BAR + } -cleanup { + mclocale $locale + namespace eval bar {::msgcat::mcforgetpackage} + namespace eval baz {::msgcat::mcforgetpackage} + namespace delete bar baz + } -body { + bar::ObjCur method1 + } -result con2baz + # Test msgcat-16.*: command mcpackagenamespaceget test msgcat-16.1 {mcpackagenamespaceget in namespace procedure} -body { - namespace eval ::baz {msgcat::mcpackagenamespaceget} - } -result ::baz + namespace eval baz {msgcat::mcpackagenamespaceget} + } -result ::msgcat::test::baz test msgcat-16.2 {mcpackagenamespaceget in class} -setup { - namespace eval ::bar { + namespace eval bar { oo::class create ClassCur oo::define ClassCur method method1 {} {msgcat::mcpackagenamespaceget} } - namespace eval ::baz { - set ObjCur [::bar::ClassCur new] + namespace eval baz { + set ObjCur [::msgcat::test::bar::ClassCur new] } } -cleanup { - namespace delete ::bar ::baz + namespace delete bar baz } -body { - $::baz::ObjCur method1 - } -result ::bar + $baz::ObjCur method1 + } -result ::msgcat::test::bar test msgcat-16.3 {mcpackagenamespaceget in classless object} -setup { - namespace eval ::bar { + namespace eval bar { oo::object create ObjCur oo::objdefine ObjCur method method1 {} {msgcat::mcpackagenamespaceget} } } -cleanup { - namespace delete ::bar + namespace delete bar + } -body { + bar::ObjCur method1 + } -result ::msgcat::test::bar + + test msgcat-16.4\ + {mcpackagenamespaceget in classless object with explicite namespace eval}\ + -setup { + namespace eval bar { + oo::object create ObjCur + oo::objdefine ObjCur method method1 {} { + namespace eval ::msgcat::test::baz { + msgcat::mcpackagenamespaceget + } + } + } + } -cleanup { + namespace delete bar baz } -body { - ::bar::ObjCur method1 - } -result ::bar + bar::ObjCur method1 + } -result ::msgcat::test::baz # Test msgcat-17.*: mcn command -- cgit v0.12 From eaacc9bb568b4c69d6a5bda83a9f11d9f0f46a80 Mon Sep 17 00:00:00 2001 From: oehhar Date: Sat, 13 Jan 2018 16:44:38 +0000 Subject: Changed msgcat version from 1.6.2 to 1.7.0 -> this is not a patch release --- changes | 2 +- library/msgcat/msgcat.tcl | 2 +- library/msgcat/pkgIndex.tcl | 2 +- unix/Makefile.in | 4 ++-- win/Makefile.in | 4 ++-- 5 files changed, 7 insertions(+), 7 deletions(-) diff --git a/changes b/changes index 51c0477..5b5a93e 100644 --- a/changes +++ b/changes @@ -8880,4 +8880,4 @@ in this changeset (new minor version) rather than bug fixes: --- Released 8.7a1, September 8, 2017 --- http://core.tcl.tk/tcl/ for details -2017-12-11 (TIP 490) add oo support for msgcat => msgcat 1.6.2 (oehlmann) +2017-12-11 (TIP 490) add oo support for msgcat => msgcat 1.7.0 (oehlmann) diff --git a/library/msgcat/msgcat.tcl b/library/msgcat/msgcat.tcl index e57802b..4233005 100644 --- a/library/msgcat/msgcat.tcl +++ b/library/msgcat/msgcat.tcl @@ -14,7 +14,7 @@ package require Tcl 8.5- # When the version number changes, be sure to update the pkgIndex.tcl file, # and the installation directory in the Makefiles. -package provide msgcat 1.6.2 +package provide msgcat 1.7.0 namespace eval msgcat { namespace export mc mcn mcexists mcload mclocale mcmax\ diff --git a/library/msgcat/pkgIndex.tcl b/library/msgcat/pkgIndex.tcl index bc58cbe..fe3b3a1 100644 --- a/library/msgcat/pkgIndex.tcl +++ b/library/msgcat/pkgIndex.tcl @@ -1,2 +1,2 @@ if {![package vsatisfies [package provide Tcl] 8.5-]} {return} -package ifneeded msgcat 1.6.2 [list source [file join $dir msgcat.tcl]] +package ifneeded msgcat 1.7.0 [list source [file join $dir msgcat.tcl]] diff --git a/unix/Makefile.in b/unix/Makefile.in index a343864..a3c0e4c 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -855,8 +855,8 @@ install-libraries: libraries do \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/opt0.4; \ done; - @echo "Installing package msgcat 1.6.2 as a Tcl Module"; - @$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/msgcat-1.6.2.tm; + @echo "Installing package msgcat 1.7.0 as a Tcl Module"; + @$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/msgcat-1.7.0.tm; @echo "Installing package tcltest 2.4.1 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.4.1.tm; diff --git a/win/Makefile.in b/win/Makefile.in index f3e1bd6..a97f1a1 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -664,8 +664,8 @@ install-libraries: libraries install-tzdata install-msgs do \ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/opt0.4"; \ done; - @echo "Installing package msgcat 1.6.2 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/msgcat-1.6.2.tm; + @echo "Installing package msgcat 1.7.0 as a Tcl Module"; + @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/msgcat-1.7.0.tm; @echo "Installing package tcltest 2.4.0 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/tcltest-2.4.0.tm; @echo "Installing package platform 1.0.14 as a Tcl Module"; -- cgit v0.12 From 87c12599bfbcd60c4b90780c1a7e653c95c2436c Mon Sep 17 00:00:00 2001 From: oehhar Date: Sat, 13 Jan 2018 17:14:22 +0000 Subject: Test numbering and naming corrected --- tests/msgcat.test | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/msgcat.test b/tests/msgcat.test index a99086d..a71ee3f 100644 --- a/tests/msgcat.test +++ b/tests/msgcat.test @@ -732,7 +732,7 @@ namespace eval ::msgcat::test { } } -result {0 1} - test msgcat-9.6 {mcexists -namespace - ns argument missing} -setup { + test msgcat-9.6 {mcexists -namespace ns parameter} -setup { mcforgetpackage variable locale [mclocale] mclocale foo_bar @@ -747,7 +747,7 @@ namespace eval ::msgcat::test { } } -result {0 1} - test msgcat-9.1 {mcexists -namespace with no parameter} -body { + test msgcat-9.7 {mcexists -namespace - ns argument missing} -body { mcexists -namespace src } -returnCodes 1\ -result {Argument missing for switch "-namespace"} -- cgit v0.12 From e841295386a779136b49e7ca3843a43279a8c185 Mon Sep 17 00:00:00 2001 From: oehhar Date: Sat, 13 Jan 2018 17:17:39 +0000 Subject: Install msgcat 1.7 in library folder 8.6 instead 8.5. It uses tailcall and will not work with 8.5 --- unix/Makefile.in | 2 +- win/Makefile.in | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/unix/Makefile.in b/unix/Makefile.in index a3c0e4c..baaab95 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -856,7 +856,7 @@ install-libraries: libraries $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/opt0.4; \ done; @echo "Installing package msgcat 1.7.0 as a Tcl Module"; - @$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/msgcat-1.7.0.tm; + @$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.6/msgcat-1.7.0.tm; @echo "Installing package tcltest 2.4.1 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.4.1.tm; diff --git a/win/Makefile.in b/win/Makefile.in index a97f1a1..131f22b 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -665,7 +665,7 @@ install-libraries: libraries install-tzdata install-msgs $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/opt0.4"; \ done; @echo "Installing package msgcat 1.7.0 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/msgcat-1.7.0.tm; + @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.6/msgcat-1.7.0.tm; @echo "Installing package tcltest 2.4.0 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/tcltest-2.4.0.tm; @echo "Installing package platform 1.0.14 as a Tcl Module"; -- cgit v0.12 From e89d1e331e09f13b01ad0436d00bf199214d4d46 Mon Sep 17 00:00:00 2001 From: oehhar Date: Tue, 16 Jan 2018 14:13:14 +0000 Subject: Solve case where msgcat is called within a class definition script (works only for 8.7) --- library/msgcat/msgcat.tcl | 29 +++++++++++++++++---------- tests/msgcat.test | 50 ++++++++++++++++++++++++++++++++++++++--------- 2 files changed, 60 insertions(+), 19 deletions(-) diff --git a/library/msgcat/msgcat.tcl b/library/msgcat/msgcat.tcl index 4233005..0b1079b 100644 --- a/library/msgcat/msgcat.tcl +++ b/library/msgcat/msgcat.tcl @@ -1151,17 +1151,26 @@ proc msgcat::ConvertLocale {value} { proc ::msgcat::PackageNamespaceGet {} { uplevel 2 { # Check for no object - # (undocumented test proposed by dkf 2018-01-12) - if { [namespace which self] ne "::oo::Helpers::self"} { - return [namespace current] - } - set Class [info object class [self]] - # Check for classless defined object - if {$Class eq {::oo::object}} { - return [namespace qualifiers [self]] + switch -exact -- [namespace which self] { + {::oo::define::self} { + # We are within a class definition + return [namespace qualifiers [self]] + } + {::oo::Helpers::self} { + # We are within an object + set Class [info object class [self]] + # Check for classless defined object + if {$Class eq {::oo::object}} { + return [namespace qualifiers [self]] + } + # Class defined object + return [namespace qualifiers $Class] + } + default { + # Not in object environment + return [namespace current] + } } - # Class defined object - return [namespace qualifiers $Class] } } diff --git a/tests/msgcat.test b/tests/msgcat.test index a71ee3f..7f872ed 100644 --- a/tests/msgcat.test +++ b/tests/msgcat.test @@ -1098,10 +1098,26 @@ namespace eval ::msgcat::test { # Tests msgcat-15.*: tcloo coverage - # There are 3 use-cases, where 2 must be tested now: - # - namespace defined, class defined oo, classless + # There are 4 use-cases, where 3 must be tested now: + # - namespace defined, in class definition, class defined oo, classless - test msgcat-15.1 {mc in class} -setup { + test msgcat-15.1 {mc in class setup} -setup { + # full namespace is ::msgcat::test:bar + namespace eval bar { + ::msgcat::mcset foo_BAR con2 con2bar + oo::class create ClassCur + } + variable locale [mclocale] + mclocale foo_BAR + } -cleanup { + mclocale $locale + namespace eval bar {::msgcat::mcforgetpackage} + namespace delete bar + } -body { + oo::define bar::ClassCur msgcat::mc con2 + } -result con2bar + + test msgcat-15.2 {mc in class} -setup { # full namespace is ::msgcat::test:bar namespace eval bar { ::msgcat::mcset foo_BAR con2 con2bar @@ -1122,7 +1138,7 @@ namespace eval ::msgcat::test { $baz::ObjCur method1 } -result con2bar - test msgcat-15.2 {mc in classless object} -setup { + test msgcat-15.3 {mc in classless object} -setup { # full namespace is ::msgcat::test:bar namespace eval bar { ::msgcat::mcset foo_BAR con2 con2bar @@ -1139,7 +1155,7 @@ namespace eval ::msgcat::test { bar::ObjCur method1 } -result con2bar - test msgcat-15.3 {mc in classless object with explicite namespace eval}\ + test msgcat-15.4 {mc in classless object with explicite namespace eval}\ -setup { # full namespace is ::msgcat::test:bar namespace eval bar { @@ -1171,7 +1187,18 @@ namespace eval ::msgcat::test { namespace eval baz {msgcat::mcpackagenamespaceget} } -result ::msgcat::test::baz - test msgcat-16.2 {mcpackagenamespaceget in class} -setup { + test msgcat-16.2 {mcpackagenamespaceget in class setup} -setup { + namespace eval bar { + oo::class create ClassCur + oo::define ClassCur variable a + } + } -cleanup { + namespace delete bar + } -body { + oo::define bar::ClassCur msgcat::mcpackagenamespaceget + } -result ::msgcat::test::bar + + test msgcat-16.3 {mcpackagenamespaceget in class} -setup { namespace eval bar { oo::class create ClassCur oo::define ClassCur method method1 {} {msgcat::mcpackagenamespaceget} @@ -1185,7 +1212,7 @@ namespace eval ::msgcat::test { $baz::ObjCur method1 } -result ::msgcat::test::bar - test msgcat-16.3 {mcpackagenamespaceget in classless object} -setup { + test msgcat-16.4 {mcpackagenamespaceget in classless object} -setup { namespace eval bar { oo::object create ObjCur oo::objdefine ObjCur method method1 {} {msgcat::mcpackagenamespaceget} @@ -1196,7 +1223,7 @@ namespace eval ::msgcat::test { bar::ObjCur method1 } -result ::msgcat::test::bar - test msgcat-16.4\ + test msgcat-16.5\ {mcpackagenamespaceget in classless object with explicite namespace eval}\ -setup { namespace eval bar { @@ -1216,7 +1243,12 @@ namespace eval ::msgcat::test { # Test msgcat-17.*: mcn command - test msgcat-17.1 {mcn} -setup { + test msgcat-17.1 {mcn no parameters} -body { + mcn + } -returnCodes 1\ + -result {wrong # args: should be "mcn ns src ?arg ...?"} + + test msgcat-17.2 {mcn} -setup { namespace eval bar {::msgcat::mcset foo_BAR con1 con1bar} variable locale [mclocale] mclocale foo_BAR -- cgit v0.12 From 7c60d44ce6b8c71d89857ce711a3f7f62ce2de2c Mon Sep 17 00:00:00 2001 From: oehhar Date: Tue, 16 Jan 2018 14:53:41 +0000 Subject: Comment updated --- library/msgcat/msgcat.tcl | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/library/msgcat/msgcat.tcl b/library/msgcat/msgcat.tcl index 0b1079b..33ff5cb 100644 --- a/library/msgcat/msgcat.tcl +++ b/library/msgcat/msgcat.tcl @@ -1144,9 +1144,10 @@ proc msgcat::ConvertLocale {value} { } # helper function to find package namespace of stack-frame -2 -# There are 3 possibilities: +# There are 4 possibilities: # - called from a proc -# - called from a oo class +# - called within a class definition script +# - called from an class defined oo object # - called from a classless oo object proc ::msgcat::PackageNamespaceGet {} { uplevel 2 { -- cgit v0.12 From 3f2c5cd5aa8381ad73336403f1ff98a52230726f Mon Sep 17 00:00:00 2001 From: oehhar Date: Wed, 7 Feb 2018 19:25:30 +0000 Subject: TIP 499: Custom locale search for msgcat --- changes | 3 + library/msgcat/msgcat.tcl | 130 ++++++++++++++++++++++++++++++++------------ library/msgcat/pkgIndex.tcl | 2 +- tests/msgcat.test | 53 +++++++++++++++++- unix/Makefile.in | 4 +- win/Makefile.in | 4 +- 6 files changed, 154 insertions(+), 42 deletions(-) mode change 100644 => 100755 changes mode change 100644 => 100755 library/msgcat/msgcat.tcl mode change 100644 => 100755 library/msgcat/pkgIndex.tcl mode change 100644 => 100755 tests/msgcat.test mode change 100644 => 100755 unix/Makefile.in mode change 100644 => 100755 win/Makefile.in diff --git a/changes b/changes old mode 100644 new mode 100755 index f89704b..120f9ff --- a/changes +++ b/changes @@ -8879,3 +8879,6 @@ in this changeset (new minor version) rather than bug fixes: 2017-09-02 (bug)[0e4d88] replace command, delete trace kills namespace (porter) --- Released 8.7a1, September 8, 2017 --- http://core.tcl.tk/tcl/ for details + +2018-02-07 (TIP 499) custom locale preference list (nijtmans) +=> msgcat 1.7.0 diff --git a/library/msgcat/msgcat.tcl b/library/msgcat/msgcat.tcl old mode 100644 new mode 100755 index 646bc17..0f8f9b3 --- a/library/msgcat/msgcat.tcl +++ b/library/msgcat/msgcat.tcl @@ -14,11 +14,11 @@ package require Tcl 8.5- # When the version number changes, be sure to update the pkgIndex.tcl file, # and the installation directory in the Makefiles. -package provide msgcat 1.6.1 +package provide msgcat 1.7.0 namespace eval msgcat { - namespace export mc mcexists mcload mclocale mcmax mcmset mcpreferences mcset\ - mcunknown mcflset mcflmset mcloadedlocales mcforgetpackage\ + namespace export mc mcexists mcload mclocale mcmax mcmset mcpreferences\ + mcset mcunknown mcflset mcflmset mcloadedlocales mcforgetpackage\ mcpackageconfig mcpackagelocale # Records the list of locales to search @@ -303,14 +303,7 @@ proc msgcat::mclocale {args} { return -code error "invalid newLocale value \"$newLocale\":\ could be path to unsafe code." } - if {[lindex $Loclist 0] ne $newLocale} { - set Loclist [GetPreferences $newLocale] - - # locale not loaded jet - LoadAll $Loclist - # Invoke callback - Invoke changecmd $Loclist - } + mcpreferences {*}[GetPreferences $newLocale] } return [lindex $Loclist 0] } @@ -349,16 +342,51 @@ proc msgcat::GetPreferences {locale} { # most preferred to least preferred. # # Arguments: -# None. +# New location list # # Results: # Returns an ordered list of the locales preferred by the user. -proc msgcat::mcpreferences {} { +proc msgcat::mcpreferences {args} { variable Loclist + + if {[llength $args] > 0} { + # args is the new loclist + if {![ListEqualString $args $Loclist]} { + set Loclist $args + + # locale not loaded jet + LoadAll $Loclist + # Invoke callback + Invoke changecmd $Loclist + } + } return $Loclist } +# msgcat::ListStringEqual -- +# +# Compare two strings for equal string contents +# +# Arguments: +# list1 first list +# list2 second list +# +# Results: +# 1 if lists of strings are identical, 0 otherwise + +proc msgcat::ListEqualString {list1 list2} { + if {[llength $list1] != [llength $list2]} { + return 0 + } + foreach item1 $list1 item2 $list2 { + if {$item1 ne $item2} { + return 0 + } + } + return 1 +} + # msgcat::mcloadedlocales -- # # Get or change the list of currently loaded default locales @@ -442,7 +470,7 @@ proc msgcat::mcloadedlocales {subcommand} { # Results: # Empty string, if not stated differently for the subcommand -proc msgcat::mcpackagelocale {subcommand {locale ""}} { +proc msgcat::mcpackagelocale {subcommand args} { # todo: implement using an ensemble variable Loclist variable LoadedLocales @@ -450,27 +478,39 @@ proc msgcat::mcpackagelocale {subcommand {locale ""}} { variable PackageConfig # Check option # check if required item is exactly provided - if {[llength [info level 0]] == 2} { - # locale not given - unset locale - } else { - # locale given - if {$subcommand in - {"get" "isset" "unset" "preferences" "loaded" "clear"} } { - return -code error "wrong # args: should be\ - \"[lrange [info level 0] 0 1]\"" - } - set locale [string tolower $locale] + if { [llength $args] > 0 + && $subcommand in {"get" "isset" "unset" "loaded" "clear"} } { + return -code error "wrong # args: should be\ + \"[lrange [info level 0] 0 1]\"" } set ns [uplevel 1 {::namespace current}] switch -exact -- $subcommand { get { return [lindex [PackagePreferences $ns] 0] } - preferences { return [PackagePreferences $ns] } loaded { return [PackageLocales $ns] } - present { return [expr {$locale in [PackageLocales $ns]} ]} + present { + if {[llength $args] != 1} { + return -code error "wrong # args: should be\ + \"[lrange [info level 0] 0 1] locale\"" + } + return [expr {[string tolower [lindex $args 0]] + in [PackageLocales $ns]} ] + } isset { return [dict exists $PackageConfig loclist $ns] } - set { # set a package locale or add a package locale + set - preferences { + # set a package locale or add a package locale + set fSet [expr {$subcommand eq "set"}] + + # Check parameter + if {$fSet && 1 < [llength $args] } { + return -code error "wrong # args: should be\ + \"[lrange [info level 0] 0 1] ?locale?\"" + } + + # > Return preferences if no parameter + if {!$fSet && 0 == [llength $args] } { + return [PackagePreferences $ns] + } # Copy the default locale if no package locale set so far if {![dict exists $PackageConfig loclist $ns]} { @@ -478,25 +518,43 @@ proc msgcat::mcpackagelocale {subcommand {locale ""}} { dict set PackageConfig loadedlocales $ns $LoadedLocales } - # Check if changed - set loclist [dict get $PackageConfig loclist $ns] - if {! [info exists locale] || $locale eq [lindex $loclist 0] } { - return [lindex $loclist 0] + # No argument for set: return current package locale + # The difference to no argument and subcommand "preferences" is, + # that "preferences" does not set the package locale property. + # This case is processed above, so no check for fSet here + if { 0 == [llength $args] } { + return [lindex [dict get $PackageConfig loclist $ns] 0] + } + + # Get new loclist + if {$fSet} { + set loclist [GetPreferences [string tolower [lindex $args 0]]] + } else { + set loclist $args + } + + # Check if not changed to return imediately + if { [ListEqualString $loclist\ + [dict get $PackageConfig loclist $ns]] } { + if {$fSet} { + return [lindex $loclist 0] + } + return $loclist } # Change loclist - set loclist [GetPreferences $locale] - set locale [lindex $loclist 0] dict set PackageConfig loclist $ns $loclist # load eventual missing locales set loadedLocales [dict get $PackageConfig loadedlocales $ns] - if {$locale in $loadedLocales} { return $locale } set loadLocales [ListComplement $loadedLocales $loclist] dict set PackageConfig loadedlocales $ns\ [concat $loadedLocales $loadLocales] Load $ns $loadLocales - return $locale + if {$fSet} { + return [lindex $loclist 0] + } + return $loclist } clear { # Remove all locales not contained in Loclist if {![dict exists $PackageConfig loclist $ns]} { diff --git a/library/msgcat/pkgIndex.tcl b/library/msgcat/pkgIndex.tcl old mode 100644 new mode 100755 index 72c5dc0..fe3b3a1 --- a/library/msgcat/pkgIndex.tcl +++ b/library/msgcat/pkgIndex.tcl @@ -1,2 +1,2 @@ if {![package vsatisfies [package provide Tcl] 8.5-]} {return} -package ifneeded msgcat 1.6.1 [list source [file join $dir msgcat.tcl]] +package ifneeded msgcat 1.7.0 [list source [file join $dir msgcat.tcl]] diff --git a/tests/msgcat.test b/tests/msgcat.test old mode 100644 new mode 100755 index 1c3ce58..b0d2bd3 --- a/tests/msgcat.test +++ b/tests/msgcat.test @@ -194,6 +194,28 @@ namespace eval ::msgcat::test { mclocale looks/ok/../../../../but/is/path/to/evil/code } -returnCodes error -match glob -result {invalid newLocale value *} + test msgcat-1.14 {mcpreferences, custom locale preferences} -setup { + variable locale [mclocale] + mclocale en + mcpreferences fr en {} + } -cleanup { + mclocale $locale + } -body { + mcpreferences + } -result {fr en {}} + + test msgcat-1.15 {mcpreferences, overwrite custom locale preferences}\ + -setup { + variable locale [mclocale] + mcpreferences fr en {} + mclocale en + } -cleanup { + mclocale $locale + } -body { + mcpreferences + } -result {en {}} + + # Tests msgcat-2.*: [mcset], [mcmset], namespace partitioning test msgcat-2.1 {mcset, global scope} { @@ -811,13 +833,18 @@ namespace eval ::msgcat::test { test msgcat-12.1 {mcpackagelocale no subcommand} -body { mcpackagelocale } -returnCodes 1\ - -result {wrong # args: should be "mcpackagelocale subcommand ?locale?"} + -result {wrong # args: should be "mcpackagelocale subcommand ?arg ...?"} test msgcat-12.2 {mclpackagelocale wrong subcommand} -body { mcpackagelocale junk } -returnCodes 1\ -result {unknown subcommand "junk": must be clear, get, isset, loaded, present, set, or unset} + test msgcat-12.2.1 {mclpackagelocale set multiple args} -body { + mcpackagelocale set a b + } -returnCodes 1\ + -result {wrong # args: should be "mcpackagelocale set ?locale?"} + test msgcat-12.3 {mcpackagelocale set} -setup { variable locale [mclocale] } -cleanup { @@ -922,6 +949,30 @@ namespace eval ::msgcat::test { list [mcpackagelocale present foo] [mcpackagelocale present bar] } -result {0 1} + test msgcat-12.11 {mcpackagelocale custom preferences} -setup { + variable locale [mclocale] + } -cleanup { + mclocale $locale + mcforgetpackage + } -body { + mclocale foo + set res [list [mcpackagelocale preferences]] + mcpackagelocale preferences bar {} + lappend res [mcpackagelocale preferences] + } -result {{foo {}} {bar {}}} + + test msgcat-12.12 {mcpackagelocale preferences -> no isset} -setup { + variable locale [mclocale] + } -cleanup { + mclocale $locale + mcforgetpackage + } -body { + mclocale foo + mcpackagelocale preferences + mcpackagelocale isset + } -result {0} + + # Tests msgcat-13.*: [mcpackageconfig subcmds] test msgcat-13.1 {mcpackageconfig no subcommand} -body { diff --git a/unix/Makefile.in b/unix/Makefile.in old mode 100644 new mode 100755 index 244ad29..4487ff5 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -850,8 +850,8 @@ install-libraries: libraries do \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/opt0.4; \ done; - @echo "Installing package msgcat 1.6.1 as a Tcl Module"; - @$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/msgcat-1.6.1.tm; + @echo "Installing package msgcat 1.7.0 as a Tcl Module"; + @$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/msgcat-1.7.0.tm; @echo "Installing package tcltest 2.4.1 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.4.1.tm; diff --git a/win/Makefile.in b/win/Makefile.in old mode 100644 new mode 100755 index 5be7492..e5e2384 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -659,8 +659,8 @@ install-libraries: libraries install-tzdata install-msgs do \ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/opt0.4"; \ done; - @echo "Installing package msgcat 1.6.1 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/msgcat-1.6.1.tm; + @echo "Installing package msgcat 1.7.0 as a Tcl Module"; + @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/msgcat-1.7.0.tm; @echo "Installing package tcltest 2.4.0 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/tcltest-2.4.0.tm; @echo "Installing package platform 1.0.14 as a Tcl Module"; -- cgit v0.12 From 4cff9271ac34377ccf2717fcb47f3c0adc8b58ee Mon Sep 17 00:00:00 2001 From: oehhar Date: Thu, 8 Feb 2018 09:49:28 +0000 Subject: Add subcommand mcpreferences to export getpreferences and getsystemlocale functions --- library/msgcat/msgcat.tcl | 54 ++++++++++++++++++++++++----------------------- tests/msgcat.test | 35 ++++++++++++++++++++++++++++++ 2 files changed, 63 insertions(+), 26 deletions(-) diff --git a/library/msgcat/msgcat.tcl b/library/msgcat/msgcat.tcl index 0f8f9b3..8fcbefb 100755 --- a/library/msgcat/msgcat.tcl +++ b/library/msgcat/msgcat.tcl @@ -19,7 +19,7 @@ package provide msgcat 1.7.0 namespace eval msgcat { namespace export mc mcexists mcload mclocale mcmax mcmset mcpreferences\ mcset mcunknown mcflset mcflmset mcloadedlocales mcforgetpackage\ - mcpackageconfig mcpackagelocale + mcpackageconfig mcpackagelocale mcutil # Records the list of locales to search variable Loclist {} @@ -41,7 +41,13 @@ namespace eval msgcat { # namespace should be themselves dict values and the value is # the translated string. variable Msgs [dict create] +} +# create ensemble namespace for mcutil command +namespace eval msgcat::mcutil { + namespace export getsystemlocale getpreferences + namespace ensemble create + # Map of language codes used in Windows registry to those of ISO-639 if {[info sharedlibextension] eq ".dll"} { variable WinRegToISO639 [dict create {*}{ @@ -303,25 +309,27 @@ proc msgcat::mclocale {args} { return -code error "invalid newLocale value \"$newLocale\":\ could be path to unsafe code." } - mcpreferences {*}[GetPreferences $newLocale] + mcpreferences {*}[mcutil getpreferences $newLocale] } return [lindex $Loclist 0] } -# msgcat::GetPreferences -- +# msgcat::mcutil::getpreferences -- # # Get list of locales from a locale. # The first element is always the lowercase locale. # Other elements have one component separated by "_" less. # Multiple "_" are seen as one separator: de__ch_spec de__ch de {} # +# This method is part of the ensemble mcutil +# # Arguments: # Locale. # # Results: # Locale list -proc msgcat::GetPreferences {locale} { +proc msgcat::mcutil::getpreferences {locale} { set locale [string tolower $locale] set loclist [list $locale] while {-1 !=[set pos [string last "_" $locale]]} { @@ -528,7 +536,7 @@ proc msgcat::mcpackagelocale {subcommand args} { # Get new loclist if {$fSet} { - set loclist [GetPreferences [string tolower [lindex $args 0]]] + set loclist [mcutil getpreferences [lindex $args 0]] } else { set loclist $args } @@ -1137,7 +1145,7 @@ proc msgcat::mcmax {args} { # Convert the locale values stored in environment variables to a form # suitable for passing to [mclocale] -proc msgcat::ConvertLocale {value} { +proc msgcat::mcutil::ConvertLocale {value} { # Assume $value is of form: $language[_$territory][.$codeset][@modifier] # Convert to form: $language[_$territory][_$modifier] # @@ -1165,7 +1173,7 @@ proc msgcat::ConvertLocale {value} { } # Initialize the default locale -proc msgcat::Init {} { +proc msgcat::mcutil::getsystemlocale {} { global env # @@ -1173,10 +1181,8 @@ proc msgcat::Init {} { # foreach varName {LC_ALL LC_MESSAGES LANG} { if {[info exists env($varName)] && ("" ne $env($varName))} { - if {![catch { - mclocale [ConvertLocale $env($varName)] - }]} { - return + if {![catch { ConvertLocale $env($varName) } locale]} { + return $locale } } } @@ -1184,10 +1190,8 @@ proc msgcat::Init {} { # On Darwin, fallback to current CFLocale identifier if available. # if {[info exists ::tcl::mac::locale] && $::tcl::mac::locale ne ""} { - if {![catch { - mclocale [ConvertLocale $::tcl::mac::locale] - }]} { - return + if {![catch { ConvertLocale $::tcl::mac::locale] } locale]} { + return $locale } } # @@ -1196,8 +1200,7 @@ proc msgcat::Init {} { # if {([info sharedlibextension] ne ".dll") || [catch {package require registry}]} { - mclocale C - return + return C } # # On Windows or Cygwin, try to set locale depending on registry @@ -1228,8 +1231,8 @@ proc msgcat::Init {} { if {[dict exists $modifierDict $script]} { append locale @ [dict get $modifierDict $script] } - if {![catch {mclocale [ConvertLocale $locale]}]} { - return + if {![catch {ConvertLocale $locale} locale]} { + return $locale } } } @@ -1238,8 +1241,7 @@ proc msgcat::Init {} { if {[catch { set locale [registry get $key "locale"] }]} { - mclocale C - return + return C } # # Keep trying to match against smaller and smaller suffixes @@ -1254,15 +1256,15 @@ proc msgcat::Init {} { set locale [string tolower $locale] while {[string length $locale]} { if {![catch { - mclocale [ConvertLocale [dict get $WinRegToISO639 $locale]] - }]} { - return + ConvertLocale [dict get $WinRegToISO639 $locale] + } localeOut]} { + return $localeOut } set locale [string range $locale 1 end] } # # No translation known. Fall back on "C" locale # - mclocale C + return C } -msgcat::Init +msgcat::mclocale [msgcat::mcutil getsystemlocale] diff --git a/tests/msgcat.test b/tests/msgcat.test index b0d2bd3..7a095a6 100755 --- a/tests/msgcat.test +++ b/tests/msgcat.test @@ -1126,6 +1126,41 @@ namespace eval ::msgcat::test { interp bgerror {} $bgerrorsaved + # Tests msgcat-15.*: [mcutil] + + test msgcat-15.1 {mcutil - no argument} -body { + mcutil + } -returnCodes 1\ + -result {wrong # args: should be "mcutil subcommand ?arg ...?"} + + test msgcat-15.2 {mcutil - wrong argument} -body { + mcutil junk + } -returnCodes 1\ + -result {unknown or ambiguous subcommand "junk": must be getpreferences, or getsystemlocale} + + test msgcat-15.3 {mcutil getpreferences - no argument} -body { + mcutil getpreferences + } -returnCodes 1\ + -result {wrong # args: should be "mcutil getpreferences locale"} + + test msgcat-15.4 {mcutil getpreferences - DE_de} -body { + mcutil getpreferences DE_de + } -result {de_de de {}} + + test msgcat-15.5 {mcutil getsystemlocale - wrong argument} -body { + mcutil getsystemlocale DE_de + } -returnCodes 1\ + -result {wrong # args: should be "mcutil getsystemlocale"} + + # The result is system dependent + # So just test if it runs + # The environment variable version was test with test 0.x + test msgcat-15.6 {mcutil getsystemlocale} -body { + mcutil getsystemlocale + set ok ok + } -result {ok} + + cleanupTests } namespace delete ::msgcat::test -- cgit v0.12 From ffae8c82da5227389ee81c50b5e22bc7678ed2f0 Mon Sep 17 00:00:00 2001 From: oehhar Date: Thu, 8 Feb 2018 12:45:50 +0000 Subject: Do not allow prefixed subcommands for mcutil --- library/msgcat/msgcat.tcl | 2 +- tests/msgcat.test | 15 ++++++++++----- 2 files changed, 11 insertions(+), 6 deletions(-) diff --git a/library/msgcat/msgcat.tcl b/library/msgcat/msgcat.tcl index 8fcbefb..3047e4d 100755 --- a/library/msgcat/msgcat.tcl +++ b/library/msgcat/msgcat.tcl @@ -46,7 +46,7 @@ namespace eval msgcat { # create ensemble namespace for mcutil command namespace eval msgcat::mcutil { namespace export getsystemlocale getpreferences - namespace ensemble create + namespace ensemble create -prefix 0 # Map of language codes used in Windows registry to those of ISO-639 if {[info sharedlibextension] eq ".dll"} { diff --git a/tests/msgcat.test b/tests/msgcat.test index 7a095a6..847836b 100755 --- a/tests/msgcat.test +++ b/tests/msgcat.test @@ -1136,18 +1136,23 @@ namespace eval ::msgcat::test { test msgcat-15.2 {mcutil - wrong argument} -body { mcutil junk } -returnCodes 1\ - -result {unknown or ambiguous subcommand "junk": must be getpreferences, or getsystemlocale} + -result {unknown subcommand "junk": must be getpreferences, or getsystemlocale} - test msgcat-15.3 {mcutil getpreferences - no argument} -body { + test msgcat-15.3 {mcutil - partial argument} -body { + mcutil getsystem + } -returnCodes 1\ + -result {unknown subcommand "getsystem": must be getpreferences, or getsystemlocale} + + test msgcat-15.4 {mcutil getpreferences - no argument} -body { mcutil getpreferences } -returnCodes 1\ -result {wrong # args: should be "mcutil getpreferences locale"} - test msgcat-15.4 {mcutil getpreferences - DE_de} -body { + test msgcat-15.5 {mcutil getpreferences - DE_de} -body { mcutil getpreferences DE_de } -result {de_de de {}} - test msgcat-15.5 {mcutil getsystemlocale - wrong argument} -body { + test msgcat-15.6 {mcutil getsystemlocale - wrong argument} -body { mcutil getsystemlocale DE_de } -returnCodes 1\ -result {wrong # args: should be "mcutil getsystemlocale"} @@ -1155,7 +1160,7 @@ namespace eval ::msgcat::test { # The result is system dependent # So just test if it runs # The environment variable version was test with test 0.x - test msgcat-15.6 {mcutil getsystemlocale} -body { + test msgcat-15.7 {mcutil getsystemlocale} -body { mcutil getsystemlocale set ok ok } -result {ok} -- cgit v0.12 From a28f176470d4f9c36163a55a0ecee4bd8d08dc3d Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 12 Mar 2018 02:48:59 +0000 Subject: It is confusingly stupid to use variable "length" to hold an actual length in part of a routine, and hold an end index value later. --- generic/tclCmdMZ.c | 35 ++++++++++++++++++++++++----------- 1 file changed, 24 insertions(+), 11 deletions(-) diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index d63a985..92f247a 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -2352,29 +2352,42 @@ StringRplcCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_UniChar *ustring; - int first, last, length; + int first, last, length, end; if (objc < 4 || objc > 5) { Tcl_WrongNumArgs(interp, 1, objv, "string first last ?string?"); return TCL_ERROR; } - ustring = Tcl_GetUnicodeFromObj(objv[1], &length); - length--; + (void) Tcl_GetUnicodeFromObj(objv[1], &length); + end = length - 1; - if (TclGetIntForIndexM(interp, objv[2], length, &first) != TCL_OK || - TclGetIntForIndexM(interp, objv[3], length, &last) != TCL_OK){ + if (TclGetIntForIndexM(interp, objv[2], end, &first) != TCL_OK || + TclGetIntForIndexM(interp, objv[3], end, &last) != TCL_OK){ return TCL_ERROR; } - if ((last < first) || (last < 0) || (first > length)) { + /* + * [string replace] does not replace empty strings. This is + * unwise, but since it is true, here we quickly screen out + * index pairs that demarcate an empty substring. + */ + + if ((last < 0) || /* Range ends before start of string */ + (first > end) || /* Range begins after end of string */ + (last < first)) { /* Range begins after it starts */ Tcl_SetObjResult(interp, objv[1]); } else { Tcl_Obj *resultPtr; - ustring = Tcl_GetUnicodeFromObj(objv[1], &length); - length--; + /* + * We are re-fetching in case the string argument is same value as + * an index argument, and shimmering cost us our ustring. + */ + + Tcl_UniChar *ustring = Tcl_GetUnicodeFromObj(objv[1], &length); + + end = length - 1; if (first < 0) { first = 0; @@ -2384,9 +2397,9 @@ StringRplcCmd( if (objc == 5) { Tcl_AppendObjToObj(resultPtr, objv[4]); } - if (last < length) { + if (last < end) { Tcl_AppendUnicodeToObj(resultPtr, ustring + last + 1, - length - last); + end - last); } Tcl_SetObjResult(interp, resultPtr); } -- cgit v0.12 From 861217dbe37cbfd71b8cf906c7b32d3ec4f04b2a Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 12 Mar 2018 13:07:50 +0000 Subject: Convert DOS -> unix line endings. --- win/makefile.vc | 2516 +++++++++++++++++++++++++++---------------------------- 1 file changed, 1258 insertions(+), 1258 deletions(-) diff --git a/win/makefile.vc b/win/makefile.vc index d647fa3..ad33ade 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -1,1258 +1,1258 @@ -#------------------------------------------------------------- -# makefile.vc -- -# -# Microsoft Visual C++ makefile for use with nmake.exe v1.62+ (VC++ 5.0+) -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# Copyright (c) 1995-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-2000 Ajuba Solutions. -# Copyright (c) 2001-2005 ActiveState Corporation. -# Copyright (c) 2001-2004 David Gravereaux. -# Copyright (c) 2003-2008 Pat Thoyts. -#------------------------------------------------------------------------------ - -# Check to see we are configured to build with MSVC (MSDEVDIR, MSVCDIR or -# VCINSTALLDIR) or with the MS Platform SDK (MSSDK or WindowsSDKDir) -!if !defined(MSDEVDIR) && !defined(MSVCDIR) && !defined(VCINSTALLDIR) && !defined(MSSDK) && !defined(WINDOWSSDKDIR) -MSG = ^ -You need to run vcvars32.bat from Developer Studio or setenv.bat from the^ -Platform SDK first to setup the environment. Jump to this line to read^ -the build instructions. -!error $(MSG) -!endif - -#------------------------------------------------------------------------------ -# HOW TO USE this makefile: -# -# 1) It is now necessary to have MSVCDir, MSDevDir or MSSDK set in the -# environment. This is used as a check to see if vcvars32.bat had been -# run prior to running nmake or during the installation of Microsoft -# Visual C++, MSVCDir had been set globally and the PATH adjusted. -# Either way is valid. -# -# You'll need to run vcvars32.bat contained in the MsDev's vc(98)/bin -# directory to setup the proper environment, if needed, for your -# current setup. This is a needed bootstrap requirement and allows the -# swapping of different environments to be easier. -# -# 2) To use the Platform SDK (not expressly needed), run setenv.bat after -# vcvars32.bat according to the instructions for it. This can also -# turn on the 64-bit compiler, if your SDK has it. -# -# 3) Targets are: -# release -- Builds the core, the shell and the dlls. (default) -# dlls -- Just builds the windows extensions -# shell -- Just builds the shell and the core. -# core -- Only builds the core [tclXX.(dll|lib)]. -# all -- Builds everything. -# test -- Builds and runs the test suite. -# tcltest -- Just builds the test shell. -# install -- Installs the built binaries and libraries to $(INSTALLDIR) -# as the root of the install tree. -# tidy/clean/hose -- varying levels of cleaning. -# genstubs -- Rebuilds the Stubs table and support files (dev only). -# depend -- Generates an accurate set of source dependancies for this -# makefile. Helpful to avoid problems when the sources are -# refreshed and you rebuild, but can "overbuild" when common -# headers like tclInt.h just get small changes. -# htmlhelp -- Builds a Windows .chm help file for Tcl and Tk from the -# troff manual pages found in $(ROOT)\doc. You need to -# have installed the HTML Help Compiler package from Microsoft -# to produce the .chm file. -# winhelp -- (deprecated) Builds the windows .hlp file for Tcl from -# the troff man files found in $(ROOT)\doc. This type of -# help file is deprecated by Microsoft in favour of html -# help files (.chm) -# -# 4) Macros usable on the commandline: -# INSTALLDIR= -# Sets where to install Tcl from the built binaries. -# C:\Progra~1\Tcl is assumed when not specified. -# -# OPTS=loimpact,msvcrt,nothreads,pdbs,profile,static,staticpkg,symbols,thrdalloc,tclalloc,unchecked,none -# Sets special options for the core. The default is for none. -# Any combination of the above may be used (comma separated). -# 'none' will over-ride everything to nothing. -# -# loimpact = Adds a flag for how NT treats the heap to keep memory -# in use, low. This is said to impact alloc performance. -# msvcrt = Affects the static option only to switch it from -# using libcmt(d) as the C runtime [by default] to -# msvcrt(d). This is useful for static embedding -# support. -# nothreads= Turns off full multithreading support. -# pdbs = Build detached symbols for release builds. -# profile = Adds profiling hooks. Map file is assumed. -# static = Builds a static library of the core instead of a -# dll. The static library will contain the dde and reg -# extensions. External applications who want to use -# this, need to link with the stub library as well as -# the static Tcl library.The shell will be static (and -# large), as well. -# staticpkg = Affects the static option only to switch -# tclshXX.exe to have the dde and reg extension linked -# inside it. -# symbols = Debug build. Links to the debug C runtime, disables -# optimizations and creates pdb symbols files. -# thrdalloc = Use the thread allocator (shared global free pool) -# This is the default on threaded builds. -# tclalloc = Use the old non-thread allocator -# unchecked= Allows a symbols build to not use the debug -# enabled runtime (msvcrt.dll not msvcrtd.dll -# or libcmt.lib not libcmtd.lib). -# -# STATS=compdbg,memdbg,none -# Sets optional memory and bytecode compiler debugging code added -# to the core. The default is for none. Any combination of the -# above may be used (comma separated). 'none' will over-ride -# everything to nothing. -# -# compdbg = Enables byte compilation logging. -# memdbg = Enables the debugging memory allocator. -# -# CHECKS=64bit,fullwarn,nodep,none -# Sets special macros for checking compatibility. -# -# 64bit = Enable 64bit portability warnings (if available) -# fullwarn = Builds with full compiler and link warnings enabled. -# Very verbose. -# nodep = Turns off compatibility macros to ensure the core -# isn't being built with deprecated functions. -# -# MACHINE=(ARM|AMD64|IA64|IX86) -# Set the machine type used for the compiler, linker, and -# resource compiler. This hook is needed to tell the tools -# when alternate platforms are requested. IX86 is the default -# when not specified. If the CPU environment variable has been -# set (ie: recent Platform SDK) then MACHINE is set from CPU. -# -# TMP_DIR= -# OUT_DIR= -# Hooks to allow the intermediate and output directories to be -# changed. $(OUT_DIR) is assumed to be -# $(BINROOT)\(Release|Debug) based on if symbols are requested. -# $(TMP_DIR) will de $(OUT_DIR)\ by default. -# -# TESTPAT= -# Reads the tests requested to be run from this file. -# -# CFG_ENCODING=encoding -# name of encoding for configuration information. Defaults -# to cp1252 -# -# 5) Examples: -# -# Basic syntax of calling nmake looks like this: -# nmake [-nologo] -f makefile.vc [target|macrodef [target|macrodef] [...]] -# -# Standard (no frills) -# c:\tcl_src\win\>c:\progra~1\micros~1\vc98\bin\vcvars32.bat -# Setting environment for using Microsoft Visual C++ tools. -# c:\tcl_src\win\>nmake -f makefile.vc release -# c:\tcl_src\win\>nmake -f makefile.vc install INSTALLDIR=c:\progra~1\tcl -# -# Building for Win64 -# c:\tcl_src\win\>c:\progra~1\micros~1\vc98\bin\vcvars32.bat -# Setting environment for using Microsoft Visual C++ tools. -# c:\tcl_src\win\>c:\progra~1\platfo~1\setenv.bat /pre64 /RETAIL -# Targeting Windows pre64 RETAIL -# c:\tcl_src\win\>nmake -f makefile.vc MACHINE=IA64 -# -#------------------------------------------------------------------------------ -#============================================================================== -############################################################################### - - -# //==================================================================\\ -# >>[ -> Do not modify below this line. <- ]<< -# >>[ Please, use the commandline macros to modify how Tcl is built. ]<< -# >>[ If you need more features, send us a patch for more macros. ]<< -# \\==================================================================// - - -############################################################################### -#============================================================================== -#------------------------------------------------------------------------------ - -!if !exist("makefile.vc") -MSG = ^ -You must run this makefile only from the directory it is in.^ -Please `cd` to its location first. -!error $(MSG) -!endif - -PROJECT = tcl -!include "rules.vc" - -STUBPREFIX = $(PROJECT)stub -DOTVERSION = $(TCL_MAJOR_VERSION).$(TCL_MINOR_VERSION) -VERSION = $(TCL_MAJOR_VERSION)$(TCL_MINOR_VERSION) - -DDEDOTVERSION = 1.4 -DDEVERSION = $(DDEDOTVERSION:.=) - -REGDOTVERSION = 1.3 -REGVERSION = $(REGDOTVERSION:.=) - -BINROOT = $(MAKEDIR) # originally . -ROOT = $(MAKEDIR)\.. # originally .. - -TCLIMPLIB = $(OUT_DIR)\$(PROJECT)$(VERSION)$(SUFX).lib -TCLLIBNAME = $(PROJECT)$(VERSION)$(SUFX).$(EXT) -TCLLIB = $(OUT_DIR)\$(TCLLIBNAME) - -TCLSTUBLIBNAME = $(STUBPREFIX)$(VERSION).lib -TCLSTUBLIB = $(OUT_DIR)\$(TCLSTUBLIBNAME) - -TCLSHNAME = $(PROJECT)sh$(VERSION)$(SUFX).exe -TCLSH = $(OUT_DIR)\$(TCLSHNAME) - -TCLREGLIBNAME = $(PROJECT)reg$(REGVERSION)$(SUFX:t=).$(EXT) -TCLREGLIB = $(OUT_DIR)\$(TCLREGLIBNAME) - -TCLDDELIBNAME = $(PROJECT)dde$(DDEVERSION)$(SUFX:t=).$(EXT) -TCLDDELIB = $(OUT_DIR)\$(TCLDDELIBNAME) - -TCLTEST = $(OUT_DIR)\$(PROJECT)test.exe -CAT32 = $(OUT_DIR)\cat32.exe - -# Can we run what we build? IX86 runs on all architectures. -!ifndef TCLSH_NATIVE -!if "$(MACHINE)" == "IX86" || "$(MACHINE)" == "$(NATIVE_ARCH)" -TCLSH_NATIVE = $(TCLSH) -!else -!error You must explicitly set TCLSH_NATIVE for cross-compilation -!endif -!endif - -### Make sure we use backslash only. -LIB_INSTALL_DIR = $(_INSTALLDIR)\lib -BIN_INSTALL_DIR = $(_INSTALLDIR)\bin -DOC_INSTALL_DIR = $(_INSTALLDIR)\doc -SCRIPT_INSTALL_DIR = $(_INSTALLDIR)\lib\tcl$(DOTVERSION) -INCLUDE_INSTALL_DIR = $(_INSTALLDIR)\include - -TCLSHOBJS = \ - $(TMP_DIR)\tclAppInit.obj \ -!if !$(STATIC_BUILD) -!if $(TCL_USE_STATIC_PACKAGES) - $(TMP_DIR)\tclWinReg.obj \ - $(TMP_DIR)\tclWinDde.obj \ -!endif -!endif - $(TMP_DIR)\tclsh.res - -TCLTESTOBJS = \ - $(TMP_DIR)\tclTest.obj \ - $(TMP_DIR)\tclTestObj.obj \ - $(TMP_DIR)\tclTestProcBodyObj.obj \ - $(TMP_DIR)\tclThreadTest.obj \ - $(TMP_DIR)\tclWinTest.obj \ -!if !$(STATIC_BUILD) -!if $(TCL_USE_STATIC_PACKAGES) - $(TMP_DIR)\tclWinReg.obj \ - $(TMP_DIR)\tclWinDde.obj \ -!endif -!endif - $(TMP_DIR)\testMain.obj - -COREOBJS = \ - $(TMP_DIR)\regcomp.obj \ - $(TMP_DIR)\regerror.obj \ - $(TMP_DIR)\regexec.obj \ - $(TMP_DIR)\regfree.obj \ - $(TMP_DIR)\tclAlloc.obj \ - $(TMP_DIR)\tclAssembly.obj \ - $(TMP_DIR)\tclAsync.obj \ - $(TMP_DIR)\tclBasic.obj \ - $(TMP_DIR)\tclBinary.obj \ - $(TMP_DIR)\tclCkalloc.obj \ - $(TMP_DIR)\tclClock.obj \ - $(TMP_DIR)\tclCmdAH.obj \ - $(TMP_DIR)\tclCmdIL.obj \ - $(TMP_DIR)\tclCmdMZ.obj \ - $(TMP_DIR)\tclCompCmds.obj \ - $(TMP_DIR)\tclCompCmdsGR.obj \ - $(TMP_DIR)\tclCompCmdsSZ.obj \ - $(TMP_DIR)\tclCompExpr.obj \ - $(TMP_DIR)\tclCompile.obj \ - $(TMP_DIR)\tclConfig.obj \ - $(TMP_DIR)\tclDate.obj \ - $(TMP_DIR)\tclDictObj.obj \ - $(TMP_DIR)\tclDisassemble.obj \ - $(TMP_DIR)\tclEncoding.obj \ - $(TMP_DIR)\tclEnsemble.obj \ - $(TMP_DIR)\tclEnv.obj \ - $(TMP_DIR)\tclEvent.obj \ - $(TMP_DIR)\tclExecute.obj \ - $(TMP_DIR)\tclFCmd.obj \ - $(TMP_DIR)\tclFileName.obj \ - $(TMP_DIR)\tclGet.obj \ - $(TMP_DIR)\tclHash.obj \ - $(TMP_DIR)\tclHistory.obj \ - $(TMP_DIR)\tclIndexObj.obj \ - $(TMP_DIR)\tclInterp.obj \ - $(TMP_DIR)\tclIO.obj \ - $(TMP_DIR)\tclIOCmd.obj \ - $(TMP_DIR)\tclIOGT.obj \ - $(TMP_DIR)\tclIOSock.obj \ - $(TMP_DIR)\tclIOUtil.obj \ - $(TMP_DIR)\tclIORChan.obj \ - $(TMP_DIR)\tclIORTrans.obj \ - $(TMP_DIR)\tclLink.obj \ - $(TMP_DIR)\tclListObj.obj \ - $(TMP_DIR)\tclLiteral.obj \ - $(TMP_DIR)\tclLoad.obj \ - $(TMP_DIR)\tclMain.obj \ - $(TMP_DIR)\tclMain2.obj \ - $(TMP_DIR)\tclNamesp.obj \ - $(TMP_DIR)\tclNotify.obj \ - $(TMP_DIR)\tclOO.obj \ - $(TMP_DIR)\tclOOBasic.obj \ - $(TMP_DIR)\tclOOCall.obj \ - $(TMP_DIR)\tclOODefineCmds.obj \ - $(TMP_DIR)\tclOOInfo.obj \ - $(TMP_DIR)\tclOOMethod.obj \ - $(TMP_DIR)\tclOOStubInit.obj \ - $(TMP_DIR)\tclObj.obj \ - $(TMP_DIR)\tclOptimize.obj \ - $(TMP_DIR)\tclPanic.obj \ - $(TMP_DIR)\tclParse.obj \ - $(TMP_DIR)\tclPathObj.obj \ - $(TMP_DIR)\tclPipe.obj \ - $(TMP_DIR)\tclPkg.obj \ - $(TMP_DIR)\tclPkgConfig.obj \ - $(TMP_DIR)\tclPosixStr.obj \ - $(TMP_DIR)\tclPreserve.obj \ - $(TMP_DIR)\tclProc.obj \ - $(TMP_DIR)\tclProcess.obj \ - $(TMP_DIR)\tclRegexp.obj \ - $(TMP_DIR)\tclResolve.obj \ - $(TMP_DIR)\tclResult.obj \ - $(TMP_DIR)\tclScan.obj \ - $(TMP_DIR)\tclStringObj.obj \ - $(TMP_DIR)\tclStrToD.obj \ - $(TMP_DIR)\tclStubInit.obj \ - $(TMP_DIR)\tclThread.obj \ - $(TMP_DIR)\tclThreadAlloc.obj \ - $(TMP_DIR)\tclThreadJoin.obj \ - $(TMP_DIR)\tclThreadStorage.obj \ - $(TMP_DIR)\tclTimer.obj \ - $(TMP_DIR)\tclTomMathInterface.obj \ - $(TMP_DIR)\tclTrace.obj \ - $(TMP_DIR)\tclUtf.obj \ - $(TMP_DIR)\tclUtil.obj \ - $(TMP_DIR)\tclVar.obj \ - $(TMP_DIR)\tclZlib.obj - -ZLIBOBJS = \ - $(TMP_DIR)\adler32.obj \ - $(TMP_DIR)\compress.obj \ - $(TMP_DIR)\crc32.obj \ - $(TMP_DIR)\deflate.obj \ - $(TMP_DIR)\infback.obj \ - $(TMP_DIR)\inffast.obj \ - $(TMP_DIR)\inflate.obj \ - $(TMP_DIR)\inftrees.obj \ - $(TMP_DIR)\trees.obj \ - $(TMP_DIR)\uncompr.obj \ - $(TMP_DIR)\zutil.obj - -TOMMATHOBJS = \ - $(TMP_DIR)\bncore.obj \ - $(TMP_DIR)\bn_reverse.obj \ - $(TMP_DIR)\bn_fast_s_mp_mul_digs.obj \ - $(TMP_DIR)\bn_fast_s_mp_sqr.obj \ - $(TMP_DIR)\bn_mp_add.obj \ - $(TMP_DIR)\bn_mp_add_d.obj \ - $(TMP_DIR)\bn_mp_and.obj \ - $(TMP_DIR)\bn_mp_clamp.obj \ - $(TMP_DIR)\bn_mp_clear.obj \ - $(TMP_DIR)\bn_mp_clear_multi.obj \ - $(TMP_DIR)\bn_mp_cmp.obj \ - $(TMP_DIR)\bn_mp_cmp_d.obj \ - $(TMP_DIR)\bn_mp_cmp_mag.obj \ - $(TMP_DIR)\bn_mp_cnt_lsb.obj \ - $(TMP_DIR)\bn_mp_copy.obj \ - $(TMP_DIR)\bn_mp_count_bits.obj \ - $(TMP_DIR)\bn_mp_div.obj \ - $(TMP_DIR)\bn_mp_div_d.obj \ - $(TMP_DIR)\bn_mp_div_2.obj \ - $(TMP_DIR)\bn_mp_div_2d.obj \ - $(TMP_DIR)\bn_mp_div_3.obj \ - $(TMP_DIR)\bn_mp_exch.obj \ - $(TMP_DIR)\bn_mp_expt_d.obj \ - $(TMP_DIR)\bn_mp_expt_d_ex.obj \ - $(TMP_DIR)\bn_mp_get_int.obj \ - $(TMP_DIR)\bn_mp_get_long.obj \ - $(TMP_DIR)\bn_mp_get_long_long.obj \ - $(TMP_DIR)\bn_mp_grow.obj \ - $(TMP_DIR)\bn_mp_init.obj \ - $(TMP_DIR)\bn_mp_init_copy.obj \ - $(TMP_DIR)\bn_mp_init_multi.obj \ - $(TMP_DIR)\bn_mp_init_set.obj \ - $(TMP_DIR)\bn_mp_init_set_int.obj \ - $(TMP_DIR)\bn_mp_init_size.obj \ - $(TMP_DIR)\bn_mp_karatsuba_mul.obj \ - $(TMP_DIR)\bn_mp_karatsuba_sqr.obj \ - $(TMP_DIR)\bn_mp_lshd.obj \ - $(TMP_DIR)\bn_mp_mod.obj \ - $(TMP_DIR)\bn_mp_mod_2d.obj \ - $(TMP_DIR)\bn_mp_mul.obj \ - $(TMP_DIR)\bn_mp_mul_2.obj \ - $(TMP_DIR)\bn_mp_mul_2d.obj \ - $(TMP_DIR)\bn_mp_mul_d.obj \ - $(TMP_DIR)\bn_mp_neg.obj \ - $(TMP_DIR)\bn_mp_or.obj \ - $(TMP_DIR)\bn_mp_radix_size.obj \ - $(TMP_DIR)\bn_mp_radix_smap.obj \ - $(TMP_DIR)\bn_mp_read_radix.obj \ - $(TMP_DIR)\bn_mp_rshd.obj \ - $(TMP_DIR)\bn_mp_set.obj \ - $(TMP_DIR)\bn_mp_set_int.obj \ - $(TMP_DIR)\bn_mp_set_long.obj \ - $(TMP_DIR)\bn_mp_set_long_long.obj \ - $(TMP_DIR)\bn_mp_shrink.obj \ - $(TMP_DIR)\bn_mp_sqr.obj \ - $(TMP_DIR)\bn_mp_sqrt.obj \ - $(TMP_DIR)\bn_mp_sub.obj \ - $(TMP_DIR)\bn_mp_sub_d.obj \ - $(TMP_DIR)\bn_mp_to_unsigned_bin.obj \ - $(TMP_DIR)\bn_mp_to_unsigned_bin_n.obj \ - $(TMP_DIR)\bn_mp_toom_mul.obj \ - $(TMP_DIR)\bn_mp_toom_sqr.obj \ - $(TMP_DIR)\bn_mp_toradix_n.obj \ - $(TMP_DIR)\bn_mp_unsigned_bin_size.obj \ - $(TMP_DIR)\bn_mp_xor.obj \ - $(TMP_DIR)\bn_mp_zero.obj \ - $(TMP_DIR)\bn_s_mp_add.obj \ - $(TMP_DIR)\bn_s_mp_mul_digs.obj \ - $(TMP_DIR)\bn_s_mp_sqr.obj \ - $(TMP_DIR)\bn_s_mp_sub.obj - -PLATFORMOBJS = \ - $(TMP_DIR)\tclWin32Dll.obj \ - $(TMP_DIR)\tclWinChan.obj \ - $(TMP_DIR)\tclWinConsole.obj \ - $(TMP_DIR)\tclWinError.obj \ - $(TMP_DIR)\tclWinFCmd.obj \ - $(TMP_DIR)\tclWinFile.obj \ - $(TMP_DIR)\tclWinInit.obj \ - $(TMP_DIR)\tclWinLoad.obj \ - $(TMP_DIR)\tclWinNotify.obj \ - $(TMP_DIR)\tclWinPipe.obj \ - $(TMP_DIR)\tclWinSerial.obj \ - $(TMP_DIR)\tclWinSock.obj \ - $(TMP_DIR)\tclWinThrd.obj \ - $(TMP_DIR)\tclWinTime.obj \ -!if $(STATIC_BUILD) - $(TMP_DIR)\tclWinReg.obj \ - $(TMP_DIR)\tclWinDde.obj \ -!else - $(TMP_DIR)\tcl.res -!endif - -TCLOBJS = $(COREOBJS) $(ZLIBOBJS) $(TOMMATHOBJS) $(PLATFORMOBJS) - -TCLSTUBOBJS = \ - $(TMP_DIR)\tclStubLib.obj \ - $(TMP_DIR)\tclTomMathStubLib.obj \ - $(TMP_DIR)\tclOOStubLib.obj - -### The following paths CANNOT have spaces in them. -COMPATDIR = $(ROOT)\compat -DOCDIR = $(ROOT)\doc -GENERICDIR = $(ROOT)\generic -TOMMATHDIR = $(ROOT)\libtommath -TOOLSDIR = $(ROOT)\tools -WINDIR = $(ROOT)\win -PKGSDIR = $(ROOT)\pkgs - -#--------------------------------------------------------------------- -# Compile flags -#--------------------------------------------------------------------- - -!if !$(DEBUG) -!if $(OPTIMIZING) -### This cranks the optimization level to maximize speed -cdebug = -O2 $(OPTIMIZATIONS) -!else -cdebug = -!endif -!if $(SYMBOLS) -cdebug = $(cdebug) -Zi -!endif -!else if "$(MACHINE)" == "IA64" || "$(MACHINE)" == "AMD64" -### Warnings are too many, can't support warnings into errors. -cdebug = -Zi -Od $(DEBUGFLAGS) -!else -cdebug = -Zi -WX $(DEBUGFLAGS) -!endif - -### Common compiler options that are architecture specific -!if "$(MACHINE)" == "ARM" -carch = -D_ARM_WINAPI_PARTITION_DESKTOP_SDK_AVAILABLE -!else -carch = -!endif - -### Declarations common to all compiler options -cwarn = $(WARNINGS) -D _CRT_SECURE_NO_DEPRECATE -D _CRT_NONSTDC_NO_DEPRECATE -cflags = -nologo -c $(COMPILERFLAGS) $(carch) $(cwarn) -Fp$(TMP_DIR)^\ - -!if $(MSVCRT) -!if $(DEBUG) && !$(UNCHECKED) -crt = -MDd -!else -crt = -MD -!endif -!else -!if $(DEBUG) && !$(UNCHECKED) -crt = -MTd -!else -crt = -MT -!endif -!endif - -TCL_INCLUDES = -I"$(WINDIR)" -I"$(GENERICDIR)" -I"$(TOMMATHDIR)" -TCL_DEFINES = -DMP_PREC=4 -Dinline=__inline -DHAVE_ZLIB=1 -BASE_CFLAGS = $(cflags) $(cdebug) $(crt) $(TCL_INCLUDES) $(TCL_DEFINES) -CON_CFLAGS = $(cflags) $(cdebug) $(crt) -DCONSOLE -TCL_CFLAGS = $(BASE_CFLAGS) $(OPTDEFINES) -STUB_CFLAGS = $(cflags) $(cdebug) $(OPTDEFINES) - - -#--------------------------------------------------------------------- -# Link flags -#--------------------------------------------------------------------- - -!if $(DEBUG) -ldebug = -debug -debugtype:cv -!else -ldebug = -release -opt:ref -opt:icf,3 -!if $(SYMBOLS) -ldebug = $(ldebug) -debug -debugtype:cv -!endif -!endif - -### Declarations common to all linker options -lflags = -nologo -machine:$(MACHINE) $(LINKERFLAGS) $(ldebug) - -!if $(PROFILE) -lflags = $(lflags) -profile -!endif - -!if $(MSVCRT) && !($(DEBUG) && !$(UNCHECKED)) && $(VCVERSION) >= 1900 -lflags = $(lflags) -nodefaultlib:libucrt.lib -!endif - -!if $(ALIGN98_HACK) && !$(STATIC_BUILD) -### Align sections for PE size savings. -lflags = $(lflags) -opt:nowin98 -!else if !$(ALIGN98_HACK) && $(STATIC_BUILD) -### Align sections for speed in loading by choosing the virtual page size. -lflags = $(lflags) -align:4096 -!endif - -!if $(LOIMPACT) -lflags = $(lflags) -ws:aggressive -!endif - -dlllflags = $(lflags) -dll -conlflags = $(lflags) -subsystem:console -guilflags = $(lflags) -subsystem:windows - -baselibs = netapi32.lib kernel32.lib user32.lib advapi32.lib userenv.lib ws2_32.lib -# Avoid 'unresolved external symbol __security_cookie' errors. -# c.f. http://support.microsoft.com/?id=894573 -!if "$(MACHINE)" == "IA64" || "$(MACHINE)" == "AMD64" -!if $(VCVERSION) > 1399 && $(VCVERSION) < 1500 -baselibs = $(baselibs) bufferoverflowU.lib -!endif -!endif -!if $(MSVCRT) && !($(DEBUG) && !$(UNCHECKED)) && $(VCVERSION) >= 1900 -baselibs = $(baselibs) ucrt.lib -!endif - -#--------------------------------------------------------------------- -# TclTest flags -#--------------------------------------------------------------------- - -!if "$(TESTPAT)" != "" -TESTFLAGS = $(TESTFLAGS) -file $(TESTPAT) -!endif - - -#--------------------------------------------------------------------- -# Project specific targets -#--------------------------------------------------------------------- - -release: setup $(TCLSH) $(TCLSTUBLIB) dlls pkgs -core: setup $(TCLLIB) $(TCLSTUBLIB) -shell: setup $(TCLSH) -dlls: setup $(TCLREGLIB) $(TCLDDELIB) -all: setup $(TCLSH) $(TCLSTUBLIB) dlls $(CAT32) pkgs -tcltest: setup $(TCLTEST) dlls $(CAT32) -install: install-binaries install-libraries install-docs install-pkgs - -test: test-core test-pkgs -test-core: setup $(TCLTEST) dlls $(CAT32) - set TCL_LIBRARY=$(ROOT:\=/)/library -!if "$(OS)" == "Windows_NT" || "$(MSVCDIR)" == "IDE" - $(DEBUGGER) $(TCLTEST) "$(ROOT:\=/)/tests/all.tcl" $(TESTFLAGS) -loadfile << - package ifneeded dde 1.4.0 [list load "$(TCLDDELIB:\=/)" dde] - package ifneeded registry 1.3.2 [list load "$(TCLREGLIB:\=/)" registry] -<< -!else - @echo Please wait while the tests are collected... - $(TCLTEST) "$(ROOT:\=/)/tests/all.tcl" $(TESTFLAGS) -loadfile << > tests.log - package ifneeded dde 1.4.0 "$(TCLDDELIB:\=/)" dde] - package ifneeded registry 1.3.2 "$(TCLREGLIB:\=/)" registry] -<< - type tests.log | more -!endif - -runtest: setup $(TCLTEST) dlls $(CAT32) - set TCL_LIBRARY=$(ROOT:\=/)/library - $(DEBUGGER) $(TCLTEST) $(SCRIPT) - -runshell: setup $(TCLSH) dlls - set TCL_LIBRARY=$(ROOT:\=/)/library - $(DEBUGGER) $(TCLSH) $(SCRIPT) - -setup: - @if not exist $(OUT_DIR)\nul mkdir $(OUT_DIR) - @if not exist $(TMP_DIR)\nul mkdir $(TMP_DIR) - -!if !$(STATIC_BUILD) -$(TCLIMPLIB): $(TCLLIB) -!endif - -$(TCLLIB): $(TCLOBJS) -!if $(STATIC_BUILD) - $(lib32) -nologo $(LINKERFLAGS) -out:$@ @<< -$** -<< -!else - $(link32) $(dlllflags) -base:@$(WINDIR)\coffbase.txt,tcl -out:$@ \ - $(baselibs) @<< -$** -<< - $(_VC_MANIFEST_EMBED_DLL) -!endif - -$(TCLSTUBLIB): $(TCLSTUBOBJS) - $(lib32) -nologo $(LINKERFLAGS) -nodefaultlib -out:$@ $(TCLSTUBOBJS) - -$(TCLSH): $(TCLSHOBJS) $(TCLSTUBLIB) $(TCLIMPLIB) - $(link32) $(conlflags) -stack:2300000 -out:$@ $(baselibs) $** - $(_VC_MANIFEST_EMBED_EXE) - -$(TCLTEST): $(TCLTESTOBJS) $(TCLSTUBLIB) $(TCLIMPLIB) - $(link32) $(conlflags) -stack:2300000 -out:$@ $(baselibs) $** - $(_VC_MANIFEST_EMBED_EXE) - -!if $(STATIC_BUILD) -$(TCLDDELIB): $(TMP_DIR)\tclWinDde.obj - $(lib32) -nologo $(LINKERFLAGS) -out:$@ $** -!else -$(TCLDDELIB): $(TMP_DIR)\tclWinDde.obj $(TCLSTUBLIB) - $(link32) $(dlllflags) -base:@$(WINDIR)\coffbase.txt,tcldde -out:$@ \ - $** $(baselibs) - $(_VC_MANIFEST_EMBED_DLL) -!endif - -!if $(STATIC_BUILD) -$(TCLREGLIB): $(TMP_DIR)\tclWinReg.obj - $(lib32) -nologo $(LINKERFLAGS) -out:$@ $** -!else -$(TCLREGLIB): $(TMP_DIR)\tclWinReg.obj $(TCLSTUBLIB) - $(link32) $(dlllflags) -base:@$(WINDIR)\coffbase.txt,tclreg -out:$@ \ - $** $(baselibs) - $(_VC_MANIFEST_EMBED_DLL) -!endif - -pkgs: - @for /d %d in ($(PKGSDIR)\*) do \ - @if exist "%~fd\win\makefile.vc" ( \ - pushd "%~fd\win" & \ - $(MAKE) -$(MAKEFLAGS) -f makefile.vc TCLDIR=$(ROOT) &\ - popd \ - ) - -test-pkgs: - @for /d %d in ($(PKGSDIR)\*) do \ - @if exist "%~fd\win\makefile.vc" ( \ - pushd "%~fd\win" & \ - $(MAKE) -$(MAKEFLAGS) -f makefile.vc TCLDIR=$(ROOT) test &\ - popd \ - ) - -install-pkgs: - @for /d %d in ($(PKGSDIR)\*) do \ - @if exist "%~fd\win\makefile.vc" ( \ - pushd "%~fd\win" & \ - $(MAKE) -$(MAKEFLAGS) -f makefile.vc TCLDIR=$(ROOT) install &\ - popd \ - ) - -clean-pkgs: - @for /d %d in ($(PKGSDIR)\*) do \ - @if exist "%~fd\win\makefile.vc" ( \ - pushd "%~fd\win" & \ - $(MAKE) -$(MAKEFLAGS) -f makefile.vc TCLDIR=$(ROOT) clean &\ - popd \ - ) - -$(CAT32): $(WINDIR)\cat.c - $(cc32) $(CON_CFLAGS) -Fo$(TMP_DIR)\ $? - $(link32) $(conlflags) -out:$@ -stack:16384 $(TMP_DIR)\cat.obj \ - $(baselibs) - $(_VC_MANIFEST_EMBED_EXE) - -#--------------------------------------------------------------------- -# Regenerate the stubs files. [Development use only] -#--------------------------------------------------------------------- - -genstubs: -!if !exist($(TCLSH)) - @echo Build tclsh first! -!else - $(TCLSH) $(TOOLSDIR:\=/)/genStubs.tcl $(GENERICDIR:\=/) \ - $(GENERICDIR:\=/)/tcl.decls $(GENERICDIR:\=/)/tclInt.decls \ - $(GENERICDIR:\=/)/tclTomMath.decls - $(TCLSH) $(TOOLSDIR:\=/)/genStubs.tcl $(GENERICDIR:\=/) \ - $(GENERICDIR:\=/)/tclOO.decls -!endif - - -#---------------------------------------------------------------------- -# The following target generates the file generic/tclTomMath.h. -# It needs to be run (and the results checked) after updating -# to a new release of libtommath. -#---------------------------------------------------------------------- - -gentommath_h: -!if !exist($(TCLSH)) - @echo Build tclsh first! -!else - $(TCLSH) "$(TOOLSDIR:\=/)/fix_tommath_h.tcl" \ - "$(TOMMATHDIR:\=/)/tommath.h" \ - > "$(GENERICDIR)\tclTomMath.h" -!endif - -#--------------------------------------------------------------------- -# Build the Windows HTML help file. -#--------------------------------------------------------------------- - -# NOTE: you can define HHC on the command-line to override this -!ifndef HHC -HHC=""%ProgramFiles%\HTML Help Workshop\hhc.exe"" -!endif -HTMLDIR=$(OUT_DIR)\html -HTMLBASE=TclTk$(VERSION) -HHPFILE=$(HTMLDIR)\$(HTMLBASE).hhp -CHMFILE=$(HTMLDIR)\$(HTMLBASE).chm - -htmlhelp: chmsetup $(CHMFILE) - -$(CHMFILE): $(DOCDIR)\* - @$(TCLSH) $(TOOLSDIR)\tcltk-man2html.tcl "--htmldir=$(HTMLDIR)" - @echo Compiling HTML help project - -$(HHC) <<$(HHPFILE) >NUL -[OPTIONS] -Compatibility=1.1 or later -Compiled file=$(HTMLBASE).chm -Default topic=contents.htm -Display compile progress=no -Error log file=$(HTMLBASE).log -Full-text search=Yes -Language=0x409 English (United States) -Title=Tcl/Tk $(DOT_VERSION) Help -[FILES] -contents.htm -docs.css -Keywords\*.htm -TclCmd\*.htm -TclLib\*.htm -TkCmd\*.htm -TkLib\*.htm -UserCmd\*.htm -<< - -chmsetup: - @if not exist $(HTMLDIR)\nul mkdir $(HTMLDIR) - -#------------------------------------------------------------------------- -# Build the old-style Windows .hlp file -#------------------------------------------------------------------------- - -TCLHLPBASE = $(PROJECT)$(VERSION) -HELPFILE = $(OUT_DIR)\$(TCLHLPBASE).hlp -HELPCNT = $(OUT_DIR)\$(TCLHLPBASE).cnt -DOCTMP_DIR = $(OUT_DIR)\$(PROJECT)_docs -HELPRTF = $(DOCTMP_DIR)\$(PROJECT).rtf -MAN2HELP = $(DOCTMP_DIR)\man2help.tcl -MAN2HELP2 = $(DOCTMP_DIR)\man2help2.tcl -INDEX = $(DOCTMP_DIR)\index.tcl -BMP = $(DOCTMP_DIR)\feather.bmp -BMP_NOPATH = feather.bmp -MAN2TCL = $(DOCTMP_DIR)\man2tcl.exe - -winhelp: docsetup $(HELPFILE) - -docsetup: - @if not exist $(DOCTMP_DIR)\nul mkdir $(DOCTMP_DIR) - -$(MAN2HELP) $(MAN2HELP2) $(INDEX) $(BMP): $(TOOLSDIR)\$$(@F) - @$(CPY) $(TOOLSDIR)\$(@F) $(@D) - -$(HELPFILE): $(HELPRTF) $(BMP) - cd $(DOCTMP_DIR) - start /wait hcrtf.exe -x <<$(PROJECT).hpj -[OPTIONS] -COMPRESS=12 Hall Zeck -LCID=0x409 0x0 0x0 ; English (United States) -TITLE=Tcl/Tk Reference Manual -BMROOT=. -CNT=$(@B).cnt -HLP=$(@B).hlp - -[FILES] -$(PROJECT).rtf - -[WINDOWS] -main="Tcl/Tk Reference Manual",,27648,(r15263976),(r65535) - -[CONFIG] -BrowseButtons() -CreateButton(1, "Web", ExecFile("http://www.tcl.tk")) -CreateButton(2, "SF", ExecFile("http://sf.net/projects/tcl")) -CreateButton(3, "Wiki", ExecFile("http://wiki.tcl.tk")) -CreateButton(4, "FAQ", ExecFile("http://www.purl.org/NET/Tcl-FAQ/")) -<< - cd $(MAKEDIR) - @$(CPY) "$(DOCTMP_DIR)\$(@B).hlp" "$(OUT_DIR)" - @$(CPY) "$(DOCTMP_DIR)\$(@B).cnt" "$(OUT_DIR)" - -$(MAN2TCL): $(TOOLSDIR)\$$(@B).c - $(cc32) $(TCL_CFLAGS) -Fo$(@D)\ $(TOOLSDIR)\$(@B).c - $(link32) $(conlflags) -out:$@ -stack:16384 $(@D)\man2tcl.obj - $(_VC_MANIFEST_EMBED_EXE) - -$(HELPRTF): $(MAN2TCL) $(MAN2HELP) $(MAN2HELP2) $(INDEX) $(DOCDIR)\* - $(TCLSH) $(MAN2HELP) -bitmap $(BMP_NOPATH) $(PROJECT) $(VERSION) $(DOCDIR:\=/) - -install-docs: -!if exist("$(CHMFILE)") - @echo Installing compiled HTML help - @$(CPY) "$(CHMFILE)" "$(DOC_INSTALL_DIR)\" -!endif -!if exist("$(HELPFILE)") - @echo Installing Windows help - @$(CPY) "$(HELPFILE)" "$(DOC_INSTALL_DIR)\" - @$(CPY) "$(HELPCNT)" "$(DOC_INSTALL_DIR)\" -!endif - -#--------------------------------------------------------------------- -# Build tclConfig.sh for the TEA build system. -#--------------------------------------------------------------------- - -tclConfig: $(OUT_DIR)\tclConfig.sh - -$(OUT_DIR)\tclConfig.sh: $(WINDIR)\tclConfig.sh.in - @echo Creating tclConfig.sh - @nmakehlp -s << $** >$@ -@TCL_DLL_FILE@ $(TCLLIBNAME) -@TCL_VERSION@ $(DOTVERSION) -@TCL_MAJOR_VERSION@ $(TCL_MAJOR_VERSION) -@TCL_MINOR_VERSION@ $(TCL_MINOR_VERSION) -@TCL_PATCH_LEVEL@ $(TCL_PATCH_LEVEL) -@CC@ $(CC) -@DEFS@ $(TCL_CFLAGS) -@CFLAGS_DEBUG@ -nologo -c -W3 -YX -Fp$(TMP_DIR)\ -MDd -@CFLAGS_OPTIMIZE@ -nologo -c -W3 -YX -Fp$(TMP_DIR)\ -MD -@LDFLAGS_DEBUG@ -nologo -machine:$(MACHINE) -debug -debugtype:cv -@LDFLAGS_OPTIMIZE@ -nologo -machine:$(MACHINE) -release -opt:ref -opt:icf,3 -@TCL_DBGX@ $(SUFX) -@TCL_LIB_FILE@ $(PROJECT)$(VERSION)$(SUFX).lib -@TCL_NEEDS_EXP_FILE@ -@LIBS@ $(baselibs) -@prefix@ $(_INSTALLDIR) -@exec_prefix@ $(BIN_INSTALL_DIR) -@SHLIB_CFLAGS@ -@STLIB_CFLAGS@ -@CFLAGS_WARNING@ -W3 -@EXTRA_CFLAGS@ -YX -@SHLIB_LD@ $(link32) $(dlllflags) -@STLIB_LD@ $(lib32) -nologo -@SHLIB_LD_LIBS@ $(baselibs) -@SHLIB_SUFFIX@ .dll -@DL_LIBS@ -@LDFLAGS@ -@TCL_CC_SEARCH_FLAGS@ -@TCL_LD_SEARCH_FLAGS@ -@LIBOBJS@ -@RANLIB@ -@TCL_LIB_FLAG@ -@TCL_BUILD_LIB_SPEC@ -@TCL_LIB_SPEC@ $(LIB_INSTALL_DIR)\$(PROJECT)$(VERSION)$(SUFX).lib -@TCL_INCLUDE_SPEC@ -I$(INCLUDE_INSTALL_DIR) -@TCL_LIB_VERSIONS_OK@ -@TCL_SRC_DIR@ $(ROOT) -@TCL_PACKAGE_PATH@ -@TCL_STUB_LIB_FILE@ $(TCLSTUBLIBNAME) -@TCL_STUB_LIB_FLAG@ $(TCLSTUBLIBNAME) -@TCL_STUB_LIB_SPEC@ -L$(LIB_INSTALL_DIR) $(TCLSTUBLIBNAME) -@TCL_THREADS@ $(TCL_THREADS) -@TCL_BUILD_STUB_LIB_SPEC@ -L$(OUT_DIR) $(TCLSTUBLIBNAME) -@TCL_BUILD_STUB_LIB_PATH@ $(TCLSTUBLIB) -@TCL_STUB_LIB_PATH@ $(LIB_INSTALL_DIR)\$(TCLSTUBLIBNAME) -@CFG_TCL_EXPORT_FILE_SUFFIX@ $(VERSION)$(SUFX).lib -@CFG_TCL_SHARED_LIB_SUFFIX@ $(VERSION)$(SUFX).dll -@CFG_TCL_UNSHARED_LIB_SUFFIX@ $(VERSION)$(SUFX).lib -!if $(STATIC_BUILD) -@TCL_SHARED_BUILD@ 0 -!else -@TCL_SHARED_BUILD@ 1 -!endif -<< - - -#--------------------------------------------------------------------- -# The following target generates the file generic/tclDate.c -# from the yacc grammar found in generic/tclGetDate.y. This is -# only run by hand as yacc is not available in all environments. -# The name of the .c file is different than the name of the .y file -# so that make doesn't try to automatically regenerate the .c file. -#--------------------------------------------------------------------- - -gendate: - bison --output-file=$(GENERICDIR)/tclDate.c \ - --name-prefix=TclDate \ - $(GENERICDIR)/tclGetDate.y - -#--------------------------------------------------------------------- -# Special case object file targets -#--------------------------------------------------------------------- - -$(TMP_DIR)\testMain.obj: $(WINDIR)\tclAppInit.c - $(cc32) $(TCL_CFLAGS) -DTCL_TEST \ - -DTCL_USE_STATIC_PACKAGES=$(TCL_USE_STATIC_PACKAGES) \ - -Fo$@ $? - -$(TMP_DIR)\tclMain2.obj: $(GENERICDIR)\tclMain.c - $(cc32) $(TCL_CFLAGS) -DBUILD_tcl -DTCL_ASCII_MAIN \ - -Fo$@ $? - -$(TMP_DIR)\tclTest.obj: $(GENERICDIR)\tclTest.c - $(cc32) $(TCL_CFLAGS) -Fo$@ $? - -$(TMP_DIR)\tclTestObj.obj: $(GENERICDIR)\tclTestObj.c - $(cc32) $(TCL_CFLAGS) -Fo$@ $? - -$(TMP_DIR)\tclWinTest.obj: $(WINDIR)\tclWinTest.c - $(cc32) $(TCL_CFLAGS) -Fo$@ $? - -$(TMP_DIR)\tclZlib.obj: $(GENERICDIR)\tclZlib.c - $(cc32) $(TCL_CFLAGS) -I$(COMPATDIR)\zlib -DBUILD_tcl -Fo$@ $? - -$(TMP_DIR)\tclPkgConfig.obj: $(GENERICDIR)\tclPkgConfig.c - $(cc32) -DBUILD_tcl $(TCL_CFLAGS) \ - -DCFG_INSTALL_LIBDIR="\"$(LIB_INSTALL_DIR:\=\\)\"" \ - -DCFG_INSTALL_BINDIR="\"$(BIN_INSTALL_DIR:\=\\)\"" \ - -DCFG_INSTALL_SCRDIR="\"$(SCRIPT_INSTALL_DIR:\=\\)\"" \ - -DCFG_INSTALL_INCDIR="\"$(INCLUDE_INSTALL_DIR:\=\\)\"" \ - -DCFG_INSTALL_DOCDIR="\"$(DOC_INSTALL_DIR:\=\\)\"" \ - -DCFG_RUNTIME_LIBDIR="\"$(LIB_INSTALL_DIR:\=\\)\"" \ - -DCFG_RUNTIME_BINDIR="\"$(BIN_INSTALL_DIR:\=\\)\"" \ - -DCFG_RUNTIME_SCRDIR="\"$(SCRIPT_INSTALL_DIR:\=\\)\"" \ - -DCFG_RUNTIME_INCDIR="\"$(INCLUDE_INSTALL_DIR:\=\\)\"" \ - -DCFG_RUNTIME_DOCDIR="\"$(DOC_INSTALL_DIR:\=\\)\"" \ - -Fo$@ $? - -$(TMP_DIR)\tclAppInit.obj: $(WINDIR)\tclAppInit.c - $(cc32) $(TCL_CFLAGS) \ - -DTCL_USE_STATIC_PACKAGES=$(TCL_USE_STATIC_PACKAGES) \ - -Fo$@ $? - -### The following objects should be built using the stub interfaces -### *ALL* extensions need to built with -DTCL_THREADS=1 - -$(TMP_DIR)\tclWinReg.obj: $(WINDIR)\tclWinReg.c -!if $(STATIC_BUILD) - $(cc32) $(TCL_CFLAGS) -DTCL_THREADS=1 -DSTATIC_BUILD -Fo$@ $? -!else - $(cc32) $(TCL_CFLAGS) -DTCL_THREADS=1 -DUSE_TCL_STUBS -Fo$@ $? -!endif - - -$(TMP_DIR)\tclWinDde.obj: $(WINDIR)\tclWinDde.c -!if $(STATIC_BUILD) - $(cc32) $(TCL_CFLAGS) -DTCL_THREADS=1 -DSTATIC_BUILD -Fo$@ $? -!else - $(cc32) $(TCL_CFLAGS) -DTCL_THREADS=1 -DUSE_TCL_STUBS -Fo$@ $? -!endif - - -### The following objects are part of the stub library and should not -### be built as DLL objects. -Zl is used to avoid a dependency on any -### specific C run-time. - -$(TMP_DIR)\tclStubLib.obj: $(GENERICDIR)\tclStubLib.c - $(cc32) $(STUB_CFLAGS) -Zl -DSTATIC_BUILD $(TCL_INCLUDES) -Fo$@ $? - -$(TMP_DIR)\tclTomMathStubLib.obj: $(GENERICDIR)\tclTomMathStubLib.c - $(cc32) $(STUB_CFLAGS) -Zl -DSTATIC_BUILD $(TCL_INCLUDES) -Fo$@ $? - -$(TMP_DIR)\tclOOStubLib.obj: $(GENERICDIR)\tclOOStubLib.c - $(cc32) $(STUB_CFLAGS) -Zl -DSTATIC_BUILD $(TCL_INCLUDES) -Fo$@ $? - -$(TMP_DIR)\tclsh.exe.manifest: $(WINDIR)\tclsh.exe.manifest.in - @nmakehlp -s << $** >$@ -@MACHINE@ $(MACHINE:IX86=X86) -@TCL_WIN_VERSION@ $(DOTVERSION).0.0 -<< - -#--------------------------------------------------------------------- -# Generate the source dependencies. Having dependency rules will -# improve incremental build accuracy without having to resort to a -# full rebuild just because some non-global header file like -# tclCompile.h was changed. These rules aren't needed when building -# from scratch. -#--------------------------------------------------------------------- - -depend: -!if !exist($(TCLSH)) - @echo Build tclsh first! -!else - $(TCLSH) $(TOOLSDIR:\=/)/mkdepend.tcl -vc32 -out:"$(OUT_DIR)\depend.mk" \ - -passthru:"-DBUILD_tcl $(TCL_INCLUDES)" $(GENERICDIR),$$(GENERICDIR) \ - $(COMPATDIR),$$(COMPATDIR) $(TOMMATHDIR),$$(TOMMATHDIR) $(WINDIR),$$(WINDIR) @<< -$(TCLOBJS) -<< -!endif - -#--------------------------------------------------------------------- -# Dependency rules -#--------------------------------------------------------------------- - -!if exist("$(OUT_DIR)\depend.mk") -!include "$(OUT_DIR)\depend.mk" -!message *** Dependency rules in use. -!else -!message *** Dependency rules are not being used. -!endif - -### add a spacer in the output -!message - - -#--------------------------------------------------------------------- -# Implicit rules. A limitation exists with nmake that requires that -# source directory can not contain spaces in the path. This an -# absolute. -#--------------------------------------------------------------------- - -{$(WINDIR)}.c{$(TMP_DIR)}.obj:: - $(cc32) $(TCL_CFLAGS) -DBUILD_tcl -Fo$(TMP_DIR)\ @<< -$< -<< - -{$(TOMMATHDIR)}.c{$(TMP_DIR)}.obj:: - $(cc32) $(TCL_CFLAGS) -DBUILD_tcl -Fo$(TMP_DIR)\ @<< -$< -<< - -{$(GENERICDIR)}.c{$(TMP_DIR)}.obj:: - $(cc32) $(TCL_CFLAGS) -DBUILD_tcl -Fo$(TMP_DIR)\ @<< -$< -<< - -{$(COMPATDIR)}.c{$(TMP_DIR)}.obj:: - $(cc32) $(TCL_CFLAGS) -DBUILD_tcl -Fo$(TMP_DIR)\ @<< -$< -<< - -{$(COMPATDIR)\zlib}.c{$(TMP_DIR)}.obj:: - $(cc32) $(TCL_CFLAGS) -DBUILD_tcl -Fo$(TMP_DIR)\ @<< -$< -<< - -{$(WINDIR)}.rc{$(TMP_DIR)}.res: - $(rc32) -fo $@ -r -i "$(GENERICDIR)" -i "$(TMP_DIR)" \ - -d DEBUG=$(DEBUG) -d UNCHECKED=$(UNCHECKED) \ - -d TCL_THREADS=$(TCL_THREADS) \ - -d STATIC_BUILD=$(STATIC_BUILD) \ - $< - -$(TMP_DIR)\tclsh.res: $(TMP_DIR)\tclsh.exe.manifest - -.SUFFIXES: -.SUFFIXES:.c .rc - - -#--------------------------------------------------------------------- -# Installation. -#--------------------------------------------------------------------- - -install-binaries: - @echo Installing to '$(_INSTALLDIR)' - @echo Installing $(TCLLIBNAME) -!if "$(TCLLIB)" != "$(TCLIMPLIB)" - @$(CPY) "$(TCLLIB)" "$(BIN_INSTALL_DIR)\" -!endif - @$(CPY) "$(TCLIMPLIB)" "$(LIB_INSTALL_DIR)\" -!if exist($(TCLSH)) - @echo Installing $(TCLSHNAME) - @$(CPY) "$(TCLSH)" "$(BIN_INSTALL_DIR)\" -!endif - @echo Installing $(TCLSTUBLIBNAME) - @$(CPY) "$(TCLSTUBLIB)" "$(LIB_INSTALL_DIR)\" - -#" emacs fix - -install-libraries: tclConfig install-msgs install-tzdata - @if not exist "$(SCRIPT_INSTALL_DIR)$(NULL)" \ - $(MKDIR) "$(SCRIPT_INSTALL_DIR)" - @if not exist "$(SCRIPT_INSTALL_DIR)\..\tcl8$(NULL)" \ - $(MKDIR) "$(SCRIPT_INSTALL_DIR)\..\tcl8" - @if not exist "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.4$(NULL)" \ - $(MKDIR) "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.4" - @if not exist "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.4\platform$(NULL)" \ - $(MKDIR) "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.4\platform" - @if not exist "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.5$(NULL)" \ - $(MKDIR) "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.5" - @if not exist "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.6$(NULL)" \ - $(MKDIR) "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.6" - @echo Installing header files - @$(CPY) "$(GENERICDIR)\tcl.h" "$(INCLUDE_INSTALL_DIR)\" - @$(CPY) "$(GENERICDIR)\tclDecls.h" "$(INCLUDE_INSTALL_DIR)\" - @$(CPY) "$(GENERICDIR)\tclOO.h" "$(INCLUDE_INSTALL_DIR)\" - @$(CPY) "$(GENERICDIR)\tclOODecls.h" "$(INCLUDE_INSTALL_DIR)\" - @$(CPY) "$(GENERICDIR)\tclPlatDecls.h" "$(INCLUDE_INSTALL_DIR)\" - @$(CPY) "$(GENERICDIR)\tclTomMath.h" "$(INCLUDE_INSTALL_DIR)\" - @$(CPY) "$(GENERICDIR)\tclTomMathDecls.h" "$(INCLUDE_INSTALL_DIR)\" - @$(CPY) "$(TOMMATHDIR)\tommath_class.h" "$(INCLUDE_INSTALL_DIR)\" - @$(CPY) "$(TOMMATHDIR)\tommath_superclass.h" "$(INCLUDE_INSTALL_DIR)\" - @echo Installing library files to $(SCRIPT_INSTALL_DIR) - @$(CPY) "$(ROOT)\library\history.tcl" "$(SCRIPT_INSTALL_DIR)\" - @$(CPY) "$(ROOT)\library\init.tcl" "$(SCRIPT_INSTALL_DIR)\" - @$(CPY) "$(ROOT)\library\clock.tcl" "$(SCRIPT_INSTALL_DIR)\" - @$(CPY) "$(ROOT)\library\tm.tcl" "$(SCRIPT_INSTALL_DIR)\" - @$(CPY) "$(ROOT)\library\parray.tcl" "$(SCRIPT_INSTALL_DIR)\" - @$(CPY) "$(ROOT)\library\safe.tcl" "$(SCRIPT_INSTALL_DIR)\" - @$(CPY) "$(ROOT)\library\tclIndex" "$(SCRIPT_INSTALL_DIR)\" - @$(CPY) "$(ROOT)\library\package.tcl" "$(SCRIPT_INSTALL_DIR)\" - @$(CPY) "$(ROOT)\library\word.tcl" "$(SCRIPT_INSTALL_DIR)\" - @$(CPY) "$(ROOT)\library\auto.tcl" "$(SCRIPT_INSTALL_DIR)\" - @$(CPY) "$(OUT_DIR)\tclConfig.sh" "$(LIB_INSTALL_DIR)\" - @$(CPY) "$(WINDIR)\tclooConfig.sh" "$(LIB_INSTALL_DIR)\" - @echo Installing library http1.0 directory - @$(CPY) "$(ROOT)\library\http1.0\*.tcl" \ - "$(SCRIPT_INSTALL_DIR)\http1.0\" - @echo Installing library opt0.4 directory - @$(CPY) "$(ROOT)\library\opt\*.tcl" \ - "$(SCRIPT_INSTALL_DIR)\opt0.4\" - @echo Installing package http $(PKG_HTTP_VER) as a Tcl Module - @$(COPY) "$(ROOT)\library\http\http.tcl" \ - "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.6\http-$(PKG_HTTP_VER).tm" - @echo Installing package msgcat $(PKG_MSGCAT_VER) as a Tcl Module - @$(COPY) "$(ROOT)\library\msgcat\msgcat.tcl" \ - "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.5\msgcat-$(PKG_MSGCAT_VER).tm" - @echo Installing package tcltest $(PKG_TCLTEST_VER) as a Tcl Module - @$(COPY) "$(ROOT)\library\tcltest\tcltest.tcl" \ - "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.5\tcltest-$(PKG_TCLTEST_VER).tm" - @echo Installing package platform $(PKG_PLATFORM_VER) as a Tcl Module - @$(COPY) "$(ROOT)\library\platform\platform.tcl" \ - "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.4\platform-$(PKG_PLATFORM_VER).tm" - @echo Installing package platform::shell $(PKG_SHELL_VER) as a Tcl Module - @$(COPY) "$(ROOT)\library\platform\shell.tcl" \ - "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.4\platform\shell-$(PKG_SHELL_VER).tm" - @echo Installing $(TCLDDELIBNAME) -!if $(STATIC_BUILD) -!if !$(TCL_USE_STATIC_PACKAGES) - @$(CPY) "$(TCLDDELIB)" "$(LIB_INSTALL_DIR)\" -!endif -!else - @$(CPY) "$(TCLDDELIB)" "$(LIB_INSTALL_DIR)\dde$(DDEDOTVERSION)\" - @$(CPY) "$(ROOT)\library\dde\pkgIndex.tcl" \ - "$(LIB_INSTALL_DIR)\dde$(DDEDOTVERSION)\" -!endif - @echo Installing $(TCLREGLIBNAME) -!if $(STATIC_BUILD) -!if !$(TCL_USE_STATIC_PACKAGES) - @$(CPY) "$(TCLREGLIB)" "$(LIB_INSTALL_DIR)\" -!endif -!else - @$(CPY) "$(TCLREGLIB)" "$(LIB_INSTALL_DIR)\reg$(REGDOTVERSION)\" - @$(CPY) "$(ROOT)\library\reg\pkgIndex.tcl" \ - "$(LIB_INSTALL_DIR)\reg$(REGDOTVERSION)\" -!endif - @echo Installing encodings - @$(CPY) "$(ROOT)\library\encoding\*.enc" \ - "$(SCRIPT_INSTALL_DIR)\encoding\" - -#" emacs fix - -install-tzdata: - @echo Installing time zone data - @set TCL_LIBRARY=$(ROOT:\=/)/library - @$(TCLSH_NATIVE) "$(ROOT:\=/)/tools/installData.tcl" \ - "$(ROOT:\=/)/library/tzdata" "$(SCRIPT_INSTALL_DIR)/tzdata" - -install-msgs: - @echo Installing message catalogs - @set TCL_LIBRARY=$(ROOT:\=/)/library - @$(TCLSH_NATIVE) "$(ROOT:\=/)/tools/installData.tcl" \ - "$(ROOT:\=/)/library/msgs" "$(SCRIPT_INSTALL_DIR)/msgs" - -#--------------------------------------------------------------------- -# Clean up -#--------------------------------------------------------------------- - -tidy: -!if "$(TCLLIB)" != "$(TCLIMPLIB)" - @echo Removing $(TCLLIB) ... - @if exist $(TCLLIB) del $(TCLLIB) -!endif - @echo Removing $(TCLIMPLIB) ... - @if exist $(TCLIMPLIB) del $(TCLIMPLIB) - @echo Removing $(TCLSH) ... - @if exist $(TCLSH) del $(TCLSH) - @echo Removing $(TCLTEST) ... - @if exist $(TCLTEST) del $(TCLTEST) - @echo Removing $(TCLDDELIB) ... - @if exist $(TCLDDELIB) del $(TCLDDELIB) - @echo Removing $(TCLREGLIB) ... - @if exist $(TCLREGLIB) del $(TCLREGLIB) - -clean: clean-pkgs - @echo Cleaning $(TMP_DIR)\* ... - @if exist $(TMP_DIR)\nul $(RMDIR) $(TMP_DIR) - @echo Cleaning $(WINDIR)\nmakehlp.obj ... - @if exist $(WINDIR)\nmakehlp.obj del $(WINDIR)\nmakehlp.obj - @echo Cleaning $(WINDIR)\nmakehlp.exe ... - @if exist $(WINDIR)\nmakehlp.exe del $(WINDIR)\nmakehlp.exe - @echo Cleaning $(WINDIR)\nmhlp-out.txt ... - @if exist $(WINDIR)\nmhlp-out.txt del $(WINDIR)\nmhlp-out.txt - @echo Cleaning $(WINDIR)\_junk.pch ... - @if exist $(WINDIR)\_junk.pch del $(WINDIR)\_junk.pch - @echo Cleaning $(WINDIR)\vercl.x ... - @if exist $(WINDIR)\vercl.x del $(WINDIR)\vercl.x - @echo Cleaning $(WINDIR)\vercl.i ... - @if exist $(WINDIR)\vercl.i del $(WINDIR)\vercl.i - @echo Cleaning $(WINDIR)\versions.vc ... - @if exist $(WINDIR)\versions.vc del $(WINDIR)\versions.vc - -realclean: hose - -hose: - @echo Hosing $(OUT_DIR)\* ... - @if exist $(OUT_DIR)\nul $(RMDIR) $(OUT_DIR) - -# Local Variables: -# mode: makefile -# End: +#------------------------------------------------------------- +# makefile.vc -- +# +# Microsoft Visual C++ makefile for use with nmake.exe v1.62+ (VC++ 5.0+) +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# Copyright (c) 1995-1996 Sun Microsystems, Inc. +# Copyright (c) 1998-2000 Ajuba Solutions. +# Copyright (c) 2001-2005 ActiveState Corporation. +# Copyright (c) 2001-2004 David Gravereaux. +# Copyright (c) 2003-2008 Pat Thoyts. +#------------------------------------------------------------------------------ + +# Check to see we are configured to build with MSVC (MSDEVDIR, MSVCDIR or +# VCINSTALLDIR) or with the MS Platform SDK (MSSDK or WindowsSDKDir) +!if !defined(MSDEVDIR) && !defined(MSVCDIR) && !defined(VCINSTALLDIR) && !defined(MSSDK) && !defined(WINDOWSSDKDIR) +MSG = ^ +You need to run vcvars32.bat from Developer Studio or setenv.bat from the^ +Platform SDK first to setup the environment. Jump to this line to read^ +the build instructions. +!error $(MSG) +!endif + +#------------------------------------------------------------------------------ +# HOW TO USE this makefile: +# +# 1) It is now necessary to have MSVCDir, MSDevDir or MSSDK set in the +# environment. This is used as a check to see if vcvars32.bat had been +# run prior to running nmake or during the installation of Microsoft +# Visual C++, MSVCDir had been set globally and the PATH adjusted. +# Either way is valid. +# +# You'll need to run vcvars32.bat contained in the MsDev's vc(98)/bin +# directory to setup the proper environment, if needed, for your +# current setup. This is a needed bootstrap requirement and allows the +# swapping of different environments to be easier. +# +# 2) To use the Platform SDK (not expressly needed), run setenv.bat after +# vcvars32.bat according to the instructions for it. This can also +# turn on the 64-bit compiler, if your SDK has it. +# +# 3) Targets are: +# release -- Builds the core, the shell and the dlls. (default) +# dlls -- Just builds the windows extensions +# shell -- Just builds the shell and the core. +# core -- Only builds the core [tclXX.(dll|lib)]. +# all -- Builds everything. +# test -- Builds and runs the test suite. +# tcltest -- Just builds the test shell. +# install -- Installs the built binaries and libraries to $(INSTALLDIR) +# as the root of the install tree. +# tidy/clean/hose -- varying levels of cleaning. +# genstubs -- Rebuilds the Stubs table and support files (dev only). +# depend -- Generates an accurate set of source dependancies for this +# makefile. Helpful to avoid problems when the sources are +# refreshed and you rebuild, but can "overbuild" when common +# headers like tclInt.h just get small changes. +# htmlhelp -- Builds a Windows .chm help file for Tcl and Tk from the +# troff manual pages found in $(ROOT)\doc. You need to +# have installed the HTML Help Compiler package from Microsoft +# to produce the .chm file. +# winhelp -- (deprecated) Builds the windows .hlp file for Tcl from +# the troff man files found in $(ROOT)\doc. This type of +# help file is deprecated by Microsoft in favour of html +# help files (.chm) +# +# 4) Macros usable on the commandline: +# INSTALLDIR= +# Sets where to install Tcl from the built binaries. +# C:\Progra~1\Tcl is assumed when not specified. +# +# OPTS=loimpact,msvcrt,nothreads,pdbs,profile,static,staticpkg,symbols,thrdalloc,tclalloc,unchecked,none +# Sets special options for the core. The default is for none. +# Any combination of the above may be used (comma separated). +# 'none' will over-ride everything to nothing. +# +# loimpact = Adds a flag for how NT treats the heap to keep memory +# in use, low. This is said to impact alloc performance. +# msvcrt = Affects the static option only to switch it from +# using libcmt(d) as the C runtime [by default] to +# msvcrt(d). This is useful for static embedding +# support. +# nothreads= Turns off full multithreading support. +# pdbs = Build detached symbols for release builds. +# profile = Adds profiling hooks. Map file is assumed. +# static = Builds a static library of the core instead of a +# dll. The static library will contain the dde and reg +# extensions. External applications who want to use +# this, need to link with the stub library as well as +# the static Tcl library.The shell will be static (and +# large), as well. +# staticpkg = Affects the static option only to switch +# tclshXX.exe to have the dde and reg extension linked +# inside it. +# symbols = Debug build. Links to the debug C runtime, disables +# optimizations and creates pdb symbols files. +# thrdalloc = Use the thread allocator (shared global free pool) +# This is the default on threaded builds. +# tclalloc = Use the old non-thread allocator +# unchecked= Allows a symbols build to not use the debug +# enabled runtime (msvcrt.dll not msvcrtd.dll +# or libcmt.lib not libcmtd.lib). +# +# STATS=compdbg,memdbg,none +# Sets optional memory and bytecode compiler debugging code added +# to the core. The default is for none. Any combination of the +# above may be used (comma separated). 'none' will over-ride +# everything to nothing. +# +# compdbg = Enables byte compilation logging. +# memdbg = Enables the debugging memory allocator. +# +# CHECKS=64bit,fullwarn,nodep,none +# Sets special macros for checking compatibility. +# +# 64bit = Enable 64bit portability warnings (if available) +# fullwarn = Builds with full compiler and link warnings enabled. +# Very verbose. +# nodep = Turns off compatibility macros to ensure the core +# isn't being built with deprecated functions. +# +# MACHINE=(ARM|AMD64|IA64|IX86) +# Set the machine type used for the compiler, linker, and +# resource compiler. This hook is needed to tell the tools +# when alternate platforms are requested. IX86 is the default +# when not specified. If the CPU environment variable has been +# set (ie: recent Platform SDK) then MACHINE is set from CPU. +# +# TMP_DIR= +# OUT_DIR= +# Hooks to allow the intermediate and output directories to be +# changed. $(OUT_DIR) is assumed to be +# $(BINROOT)\(Release|Debug) based on if symbols are requested. +# $(TMP_DIR) will de $(OUT_DIR)\ by default. +# +# TESTPAT= +# Reads the tests requested to be run from this file. +# +# CFG_ENCODING=encoding +# name of encoding for configuration information. Defaults +# to cp1252 +# +# 5) Examples: +# +# Basic syntax of calling nmake looks like this: +# nmake [-nologo] -f makefile.vc [target|macrodef [target|macrodef] [...]] +# +# Standard (no frills) +# c:\tcl_src\win\>c:\progra~1\micros~1\vc98\bin\vcvars32.bat +# Setting environment for using Microsoft Visual C++ tools. +# c:\tcl_src\win\>nmake -f makefile.vc release +# c:\tcl_src\win\>nmake -f makefile.vc install INSTALLDIR=c:\progra~1\tcl +# +# Building for Win64 +# c:\tcl_src\win\>c:\progra~1\micros~1\vc98\bin\vcvars32.bat +# Setting environment for using Microsoft Visual C++ tools. +# c:\tcl_src\win\>c:\progra~1\platfo~1\setenv.bat /pre64 /RETAIL +# Targeting Windows pre64 RETAIL +# c:\tcl_src\win\>nmake -f makefile.vc MACHINE=IA64 +# +#------------------------------------------------------------------------------ +#============================================================================== +############################################################################### + + +# //==================================================================\\ +# >>[ -> Do not modify below this line. <- ]<< +# >>[ Please, use the commandline macros to modify how Tcl is built. ]<< +# >>[ If you need more features, send us a patch for more macros. ]<< +# \\==================================================================// + + +############################################################################### +#============================================================================== +#------------------------------------------------------------------------------ + +!if !exist("makefile.vc") +MSG = ^ +You must run this makefile only from the directory it is in.^ +Please `cd` to its location first. +!error $(MSG) +!endif + +PROJECT = tcl +!include "rules.vc" + +STUBPREFIX = $(PROJECT)stub +DOTVERSION = $(TCL_MAJOR_VERSION).$(TCL_MINOR_VERSION) +VERSION = $(TCL_MAJOR_VERSION)$(TCL_MINOR_VERSION) + +DDEDOTVERSION = 1.4 +DDEVERSION = $(DDEDOTVERSION:.=) + +REGDOTVERSION = 1.3 +REGVERSION = $(REGDOTVERSION:.=) + +BINROOT = $(MAKEDIR) # originally . +ROOT = $(MAKEDIR)\.. # originally .. + +TCLIMPLIB = $(OUT_DIR)\$(PROJECT)$(VERSION)$(SUFX).lib +TCLLIBNAME = $(PROJECT)$(VERSION)$(SUFX).$(EXT) +TCLLIB = $(OUT_DIR)\$(TCLLIBNAME) + +TCLSTUBLIBNAME = $(STUBPREFIX)$(VERSION).lib +TCLSTUBLIB = $(OUT_DIR)\$(TCLSTUBLIBNAME) + +TCLSHNAME = $(PROJECT)sh$(VERSION)$(SUFX).exe +TCLSH = $(OUT_DIR)\$(TCLSHNAME) + +TCLREGLIBNAME = $(PROJECT)reg$(REGVERSION)$(SUFX:t=).$(EXT) +TCLREGLIB = $(OUT_DIR)\$(TCLREGLIBNAME) + +TCLDDELIBNAME = $(PROJECT)dde$(DDEVERSION)$(SUFX:t=).$(EXT) +TCLDDELIB = $(OUT_DIR)\$(TCLDDELIBNAME) + +TCLTEST = $(OUT_DIR)\$(PROJECT)test.exe +CAT32 = $(OUT_DIR)\cat32.exe + +# Can we run what we build? IX86 runs on all architectures. +!ifndef TCLSH_NATIVE +!if "$(MACHINE)" == "IX86" || "$(MACHINE)" == "$(NATIVE_ARCH)" +TCLSH_NATIVE = $(TCLSH) +!else +!error You must explicitly set TCLSH_NATIVE for cross-compilation +!endif +!endif + +### Make sure we use backslash only. +LIB_INSTALL_DIR = $(_INSTALLDIR)\lib +BIN_INSTALL_DIR = $(_INSTALLDIR)\bin +DOC_INSTALL_DIR = $(_INSTALLDIR)\doc +SCRIPT_INSTALL_DIR = $(_INSTALLDIR)\lib\tcl$(DOTVERSION) +INCLUDE_INSTALL_DIR = $(_INSTALLDIR)\include + +TCLSHOBJS = \ + $(TMP_DIR)\tclAppInit.obj \ +!if !$(STATIC_BUILD) +!if $(TCL_USE_STATIC_PACKAGES) + $(TMP_DIR)\tclWinReg.obj \ + $(TMP_DIR)\tclWinDde.obj \ +!endif +!endif + $(TMP_DIR)\tclsh.res + +TCLTESTOBJS = \ + $(TMP_DIR)\tclTest.obj \ + $(TMP_DIR)\tclTestObj.obj \ + $(TMP_DIR)\tclTestProcBodyObj.obj \ + $(TMP_DIR)\tclThreadTest.obj \ + $(TMP_DIR)\tclWinTest.obj \ +!if !$(STATIC_BUILD) +!if $(TCL_USE_STATIC_PACKAGES) + $(TMP_DIR)\tclWinReg.obj \ + $(TMP_DIR)\tclWinDde.obj \ +!endif +!endif + $(TMP_DIR)\testMain.obj + +COREOBJS = \ + $(TMP_DIR)\regcomp.obj \ + $(TMP_DIR)\regerror.obj \ + $(TMP_DIR)\regexec.obj \ + $(TMP_DIR)\regfree.obj \ + $(TMP_DIR)\tclAlloc.obj \ + $(TMP_DIR)\tclAssembly.obj \ + $(TMP_DIR)\tclAsync.obj \ + $(TMP_DIR)\tclBasic.obj \ + $(TMP_DIR)\tclBinary.obj \ + $(TMP_DIR)\tclCkalloc.obj \ + $(TMP_DIR)\tclClock.obj \ + $(TMP_DIR)\tclCmdAH.obj \ + $(TMP_DIR)\tclCmdIL.obj \ + $(TMP_DIR)\tclCmdMZ.obj \ + $(TMP_DIR)\tclCompCmds.obj \ + $(TMP_DIR)\tclCompCmdsGR.obj \ + $(TMP_DIR)\tclCompCmdsSZ.obj \ + $(TMP_DIR)\tclCompExpr.obj \ + $(TMP_DIR)\tclCompile.obj \ + $(TMP_DIR)\tclConfig.obj \ + $(TMP_DIR)\tclDate.obj \ + $(TMP_DIR)\tclDictObj.obj \ + $(TMP_DIR)\tclDisassemble.obj \ + $(TMP_DIR)\tclEncoding.obj \ + $(TMP_DIR)\tclEnsemble.obj \ + $(TMP_DIR)\tclEnv.obj \ + $(TMP_DIR)\tclEvent.obj \ + $(TMP_DIR)\tclExecute.obj \ + $(TMP_DIR)\tclFCmd.obj \ + $(TMP_DIR)\tclFileName.obj \ + $(TMP_DIR)\tclGet.obj \ + $(TMP_DIR)\tclHash.obj \ + $(TMP_DIR)\tclHistory.obj \ + $(TMP_DIR)\tclIndexObj.obj \ + $(TMP_DIR)\tclInterp.obj \ + $(TMP_DIR)\tclIO.obj \ + $(TMP_DIR)\tclIOCmd.obj \ + $(TMP_DIR)\tclIOGT.obj \ + $(TMP_DIR)\tclIOSock.obj \ + $(TMP_DIR)\tclIOUtil.obj \ + $(TMP_DIR)\tclIORChan.obj \ + $(TMP_DIR)\tclIORTrans.obj \ + $(TMP_DIR)\tclLink.obj \ + $(TMP_DIR)\tclListObj.obj \ + $(TMP_DIR)\tclLiteral.obj \ + $(TMP_DIR)\tclLoad.obj \ + $(TMP_DIR)\tclMain.obj \ + $(TMP_DIR)\tclMain2.obj \ + $(TMP_DIR)\tclNamesp.obj \ + $(TMP_DIR)\tclNotify.obj \ + $(TMP_DIR)\tclOO.obj \ + $(TMP_DIR)\tclOOBasic.obj \ + $(TMP_DIR)\tclOOCall.obj \ + $(TMP_DIR)\tclOODefineCmds.obj \ + $(TMP_DIR)\tclOOInfo.obj \ + $(TMP_DIR)\tclOOMethod.obj \ + $(TMP_DIR)\tclOOStubInit.obj \ + $(TMP_DIR)\tclObj.obj \ + $(TMP_DIR)\tclOptimize.obj \ + $(TMP_DIR)\tclPanic.obj \ + $(TMP_DIR)\tclParse.obj \ + $(TMP_DIR)\tclPathObj.obj \ + $(TMP_DIR)\tclPipe.obj \ + $(TMP_DIR)\tclPkg.obj \ + $(TMP_DIR)\tclPkgConfig.obj \ + $(TMP_DIR)\tclPosixStr.obj \ + $(TMP_DIR)\tclPreserve.obj \ + $(TMP_DIR)\tclProc.obj \ + $(TMP_DIR)\tclProcess.obj \ + $(TMP_DIR)\tclRegexp.obj \ + $(TMP_DIR)\tclResolve.obj \ + $(TMP_DIR)\tclResult.obj \ + $(TMP_DIR)\tclScan.obj \ + $(TMP_DIR)\tclStringObj.obj \ + $(TMP_DIR)\tclStrToD.obj \ + $(TMP_DIR)\tclStubInit.obj \ + $(TMP_DIR)\tclThread.obj \ + $(TMP_DIR)\tclThreadAlloc.obj \ + $(TMP_DIR)\tclThreadJoin.obj \ + $(TMP_DIR)\tclThreadStorage.obj \ + $(TMP_DIR)\tclTimer.obj \ + $(TMP_DIR)\tclTomMathInterface.obj \ + $(TMP_DIR)\tclTrace.obj \ + $(TMP_DIR)\tclUtf.obj \ + $(TMP_DIR)\tclUtil.obj \ + $(TMP_DIR)\tclVar.obj \ + $(TMP_DIR)\tclZlib.obj + +ZLIBOBJS = \ + $(TMP_DIR)\adler32.obj \ + $(TMP_DIR)\compress.obj \ + $(TMP_DIR)\crc32.obj \ + $(TMP_DIR)\deflate.obj \ + $(TMP_DIR)\infback.obj \ + $(TMP_DIR)\inffast.obj \ + $(TMP_DIR)\inflate.obj \ + $(TMP_DIR)\inftrees.obj \ + $(TMP_DIR)\trees.obj \ + $(TMP_DIR)\uncompr.obj \ + $(TMP_DIR)\zutil.obj + +TOMMATHOBJS = \ + $(TMP_DIR)\bncore.obj \ + $(TMP_DIR)\bn_reverse.obj \ + $(TMP_DIR)\bn_fast_s_mp_mul_digs.obj \ + $(TMP_DIR)\bn_fast_s_mp_sqr.obj \ + $(TMP_DIR)\bn_mp_add.obj \ + $(TMP_DIR)\bn_mp_add_d.obj \ + $(TMP_DIR)\bn_mp_and.obj \ + $(TMP_DIR)\bn_mp_clamp.obj \ + $(TMP_DIR)\bn_mp_clear.obj \ + $(TMP_DIR)\bn_mp_clear_multi.obj \ + $(TMP_DIR)\bn_mp_cmp.obj \ + $(TMP_DIR)\bn_mp_cmp_d.obj \ + $(TMP_DIR)\bn_mp_cmp_mag.obj \ + $(TMP_DIR)\bn_mp_cnt_lsb.obj \ + $(TMP_DIR)\bn_mp_copy.obj \ + $(TMP_DIR)\bn_mp_count_bits.obj \ + $(TMP_DIR)\bn_mp_div.obj \ + $(TMP_DIR)\bn_mp_div_d.obj \ + $(TMP_DIR)\bn_mp_div_2.obj \ + $(TMP_DIR)\bn_mp_div_2d.obj \ + $(TMP_DIR)\bn_mp_div_3.obj \ + $(TMP_DIR)\bn_mp_exch.obj \ + $(TMP_DIR)\bn_mp_expt_d.obj \ + $(TMP_DIR)\bn_mp_expt_d_ex.obj \ + $(TMP_DIR)\bn_mp_get_int.obj \ + $(TMP_DIR)\bn_mp_get_long.obj \ + $(TMP_DIR)\bn_mp_get_long_long.obj \ + $(TMP_DIR)\bn_mp_grow.obj \ + $(TMP_DIR)\bn_mp_init.obj \ + $(TMP_DIR)\bn_mp_init_copy.obj \ + $(TMP_DIR)\bn_mp_init_multi.obj \ + $(TMP_DIR)\bn_mp_init_set.obj \ + $(TMP_DIR)\bn_mp_init_set_int.obj \ + $(TMP_DIR)\bn_mp_init_size.obj \ + $(TMP_DIR)\bn_mp_karatsuba_mul.obj \ + $(TMP_DIR)\bn_mp_karatsuba_sqr.obj \ + $(TMP_DIR)\bn_mp_lshd.obj \ + $(TMP_DIR)\bn_mp_mod.obj \ + $(TMP_DIR)\bn_mp_mod_2d.obj \ + $(TMP_DIR)\bn_mp_mul.obj \ + $(TMP_DIR)\bn_mp_mul_2.obj \ + $(TMP_DIR)\bn_mp_mul_2d.obj \ + $(TMP_DIR)\bn_mp_mul_d.obj \ + $(TMP_DIR)\bn_mp_neg.obj \ + $(TMP_DIR)\bn_mp_or.obj \ + $(TMP_DIR)\bn_mp_radix_size.obj \ + $(TMP_DIR)\bn_mp_radix_smap.obj \ + $(TMP_DIR)\bn_mp_read_radix.obj \ + $(TMP_DIR)\bn_mp_rshd.obj \ + $(TMP_DIR)\bn_mp_set.obj \ + $(TMP_DIR)\bn_mp_set_int.obj \ + $(TMP_DIR)\bn_mp_set_long.obj \ + $(TMP_DIR)\bn_mp_set_long_long.obj \ + $(TMP_DIR)\bn_mp_shrink.obj \ + $(TMP_DIR)\bn_mp_sqr.obj \ + $(TMP_DIR)\bn_mp_sqrt.obj \ + $(TMP_DIR)\bn_mp_sub.obj \ + $(TMP_DIR)\bn_mp_sub_d.obj \ + $(TMP_DIR)\bn_mp_to_unsigned_bin.obj \ + $(TMP_DIR)\bn_mp_to_unsigned_bin_n.obj \ + $(TMP_DIR)\bn_mp_toom_mul.obj \ + $(TMP_DIR)\bn_mp_toom_sqr.obj \ + $(TMP_DIR)\bn_mp_toradix_n.obj \ + $(TMP_DIR)\bn_mp_unsigned_bin_size.obj \ + $(TMP_DIR)\bn_mp_xor.obj \ + $(TMP_DIR)\bn_mp_zero.obj \ + $(TMP_DIR)\bn_s_mp_add.obj \ + $(TMP_DIR)\bn_s_mp_mul_digs.obj \ + $(TMP_DIR)\bn_s_mp_sqr.obj \ + $(TMP_DIR)\bn_s_mp_sub.obj + +PLATFORMOBJS = \ + $(TMP_DIR)\tclWin32Dll.obj \ + $(TMP_DIR)\tclWinChan.obj \ + $(TMP_DIR)\tclWinConsole.obj \ + $(TMP_DIR)\tclWinError.obj \ + $(TMP_DIR)\tclWinFCmd.obj \ + $(TMP_DIR)\tclWinFile.obj \ + $(TMP_DIR)\tclWinInit.obj \ + $(TMP_DIR)\tclWinLoad.obj \ + $(TMP_DIR)\tclWinNotify.obj \ + $(TMP_DIR)\tclWinPipe.obj \ + $(TMP_DIR)\tclWinSerial.obj \ + $(TMP_DIR)\tclWinSock.obj \ + $(TMP_DIR)\tclWinThrd.obj \ + $(TMP_DIR)\tclWinTime.obj \ +!if $(STATIC_BUILD) + $(TMP_DIR)\tclWinReg.obj \ + $(TMP_DIR)\tclWinDde.obj \ +!else + $(TMP_DIR)\tcl.res +!endif + +TCLOBJS = $(COREOBJS) $(ZLIBOBJS) $(TOMMATHOBJS) $(PLATFORMOBJS) + +TCLSTUBOBJS = \ + $(TMP_DIR)\tclStubLib.obj \ + $(TMP_DIR)\tclTomMathStubLib.obj \ + $(TMP_DIR)\tclOOStubLib.obj + +### The following paths CANNOT have spaces in them. +COMPATDIR = $(ROOT)\compat +DOCDIR = $(ROOT)\doc +GENERICDIR = $(ROOT)\generic +TOMMATHDIR = $(ROOT)\libtommath +TOOLSDIR = $(ROOT)\tools +WINDIR = $(ROOT)\win +PKGSDIR = $(ROOT)\pkgs + +#--------------------------------------------------------------------- +# Compile flags +#--------------------------------------------------------------------- + +!if !$(DEBUG) +!if $(OPTIMIZING) +### This cranks the optimization level to maximize speed +cdebug = -O2 $(OPTIMIZATIONS) +!else +cdebug = +!endif +!if $(SYMBOLS) +cdebug = $(cdebug) -Zi +!endif +!else if "$(MACHINE)" == "IA64" || "$(MACHINE)" == "AMD64" +### Warnings are too many, can't support warnings into errors. +cdebug = -Zi -Od $(DEBUGFLAGS) +!else +cdebug = -Zi -WX $(DEBUGFLAGS) +!endif + +### Common compiler options that are architecture specific +!if "$(MACHINE)" == "ARM" +carch = -D_ARM_WINAPI_PARTITION_DESKTOP_SDK_AVAILABLE +!else +carch = +!endif + +### Declarations common to all compiler options +cwarn = $(WARNINGS) -D _CRT_SECURE_NO_DEPRECATE -D _CRT_NONSTDC_NO_DEPRECATE +cflags = -nologo -c $(COMPILERFLAGS) $(carch) $(cwarn) -Fp$(TMP_DIR)^\ + +!if $(MSVCRT) +!if $(DEBUG) && !$(UNCHECKED) +crt = -MDd +!else +crt = -MD +!endif +!else +!if $(DEBUG) && !$(UNCHECKED) +crt = -MTd +!else +crt = -MT +!endif +!endif + +TCL_INCLUDES = -I"$(WINDIR)" -I"$(GENERICDIR)" -I"$(TOMMATHDIR)" +TCL_DEFINES = -DMP_PREC=4 -Dinline=__inline -DHAVE_ZLIB=1 +BASE_CFLAGS = $(cflags) $(cdebug) $(crt) $(TCL_INCLUDES) $(TCL_DEFINES) +CON_CFLAGS = $(cflags) $(cdebug) $(crt) -DCONSOLE +TCL_CFLAGS = $(BASE_CFLAGS) $(OPTDEFINES) +STUB_CFLAGS = $(cflags) $(cdebug) $(OPTDEFINES) + + +#--------------------------------------------------------------------- +# Link flags +#--------------------------------------------------------------------- + +!if $(DEBUG) +ldebug = -debug -debugtype:cv +!else +ldebug = -release -opt:ref -opt:icf,3 +!if $(SYMBOLS) +ldebug = $(ldebug) -debug -debugtype:cv +!endif +!endif + +### Declarations common to all linker options +lflags = -nologo -machine:$(MACHINE) $(LINKERFLAGS) $(ldebug) + +!if $(PROFILE) +lflags = $(lflags) -profile +!endif + +!if $(MSVCRT) && !($(DEBUG) && !$(UNCHECKED)) && $(VCVERSION) >= 1900 +lflags = $(lflags) -nodefaultlib:libucrt.lib +!endif + +!if $(ALIGN98_HACK) && !$(STATIC_BUILD) +### Align sections for PE size savings. +lflags = $(lflags) -opt:nowin98 +!else if !$(ALIGN98_HACK) && $(STATIC_BUILD) +### Align sections for speed in loading by choosing the virtual page size. +lflags = $(lflags) -align:4096 +!endif + +!if $(LOIMPACT) +lflags = $(lflags) -ws:aggressive +!endif + +dlllflags = $(lflags) -dll +conlflags = $(lflags) -subsystem:console +guilflags = $(lflags) -subsystem:windows + +baselibs = netapi32.lib kernel32.lib user32.lib advapi32.lib userenv.lib ws2_32.lib +# Avoid 'unresolved external symbol __security_cookie' errors. +# c.f. http://support.microsoft.com/?id=894573 +!if "$(MACHINE)" == "IA64" || "$(MACHINE)" == "AMD64" +!if $(VCVERSION) > 1399 && $(VCVERSION) < 1500 +baselibs = $(baselibs) bufferoverflowU.lib +!endif +!endif +!if $(MSVCRT) && !($(DEBUG) && !$(UNCHECKED)) && $(VCVERSION) >= 1900 +baselibs = $(baselibs) ucrt.lib +!endif + +#--------------------------------------------------------------------- +# TclTest flags +#--------------------------------------------------------------------- + +!if "$(TESTPAT)" != "" +TESTFLAGS = $(TESTFLAGS) -file $(TESTPAT) +!endif + + +#--------------------------------------------------------------------- +# Project specific targets +#--------------------------------------------------------------------- + +release: setup $(TCLSH) $(TCLSTUBLIB) dlls pkgs +core: setup $(TCLLIB) $(TCLSTUBLIB) +shell: setup $(TCLSH) +dlls: setup $(TCLREGLIB) $(TCLDDELIB) +all: setup $(TCLSH) $(TCLSTUBLIB) dlls $(CAT32) pkgs +tcltest: setup $(TCLTEST) dlls $(CAT32) +install: install-binaries install-libraries install-docs install-pkgs + +test: test-core test-pkgs +test-core: setup $(TCLTEST) dlls $(CAT32) + set TCL_LIBRARY=$(ROOT:\=/)/library +!if "$(OS)" == "Windows_NT" || "$(MSVCDIR)" == "IDE" + $(DEBUGGER) $(TCLTEST) "$(ROOT:\=/)/tests/all.tcl" $(TESTFLAGS) -loadfile << + package ifneeded dde 1.4.0 [list load "$(TCLDDELIB:\=/)" dde] + package ifneeded registry 1.3.2 [list load "$(TCLREGLIB:\=/)" registry] +<< +!else + @echo Please wait while the tests are collected... + $(TCLTEST) "$(ROOT:\=/)/tests/all.tcl" $(TESTFLAGS) -loadfile << > tests.log + package ifneeded dde 1.4.0 "$(TCLDDELIB:\=/)" dde] + package ifneeded registry 1.3.2 "$(TCLREGLIB:\=/)" registry] +<< + type tests.log | more +!endif + +runtest: setup $(TCLTEST) dlls $(CAT32) + set TCL_LIBRARY=$(ROOT:\=/)/library + $(DEBUGGER) $(TCLTEST) $(SCRIPT) + +runshell: setup $(TCLSH) dlls + set TCL_LIBRARY=$(ROOT:\=/)/library + $(DEBUGGER) $(TCLSH) $(SCRIPT) + +setup: + @if not exist $(OUT_DIR)\nul mkdir $(OUT_DIR) + @if not exist $(TMP_DIR)\nul mkdir $(TMP_DIR) + +!if !$(STATIC_BUILD) +$(TCLIMPLIB): $(TCLLIB) +!endif + +$(TCLLIB): $(TCLOBJS) +!if $(STATIC_BUILD) + $(lib32) -nologo $(LINKERFLAGS) -out:$@ @<< +$** +<< +!else + $(link32) $(dlllflags) -base:@$(WINDIR)\coffbase.txt,tcl -out:$@ \ + $(baselibs) @<< +$** +<< + $(_VC_MANIFEST_EMBED_DLL) +!endif + +$(TCLSTUBLIB): $(TCLSTUBOBJS) + $(lib32) -nologo $(LINKERFLAGS) -nodefaultlib -out:$@ $(TCLSTUBOBJS) + +$(TCLSH): $(TCLSHOBJS) $(TCLSTUBLIB) $(TCLIMPLIB) + $(link32) $(conlflags) -stack:2300000 -out:$@ $(baselibs) $** + $(_VC_MANIFEST_EMBED_EXE) + +$(TCLTEST): $(TCLTESTOBJS) $(TCLSTUBLIB) $(TCLIMPLIB) + $(link32) $(conlflags) -stack:2300000 -out:$@ $(baselibs) $** + $(_VC_MANIFEST_EMBED_EXE) + +!if $(STATIC_BUILD) +$(TCLDDELIB): $(TMP_DIR)\tclWinDde.obj + $(lib32) -nologo $(LINKERFLAGS) -out:$@ $** +!else +$(TCLDDELIB): $(TMP_DIR)\tclWinDde.obj $(TCLSTUBLIB) + $(link32) $(dlllflags) -base:@$(WINDIR)\coffbase.txt,tcldde -out:$@ \ + $** $(baselibs) + $(_VC_MANIFEST_EMBED_DLL) +!endif + +!if $(STATIC_BUILD) +$(TCLREGLIB): $(TMP_DIR)\tclWinReg.obj + $(lib32) -nologo $(LINKERFLAGS) -out:$@ $** +!else +$(TCLREGLIB): $(TMP_DIR)\tclWinReg.obj $(TCLSTUBLIB) + $(link32) $(dlllflags) -base:@$(WINDIR)\coffbase.txt,tclreg -out:$@ \ + $** $(baselibs) + $(_VC_MANIFEST_EMBED_DLL) +!endif + +pkgs: + @for /d %d in ($(PKGSDIR)\*) do \ + @if exist "%~fd\win\makefile.vc" ( \ + pushd "%~fd\win" & \ + $(MAKE) -$(MAKEFLAGS) -f makefile.vc TCLDIR=$(ROOT) &\ + popd \ + ) + +test-pkgs: + @for /d %d in ($(PKGSDIR)\*) do \ + @if exist "%~fd\win\makefile.vc" ( \ + pushd "%~fd\win" & \ + $(MAKE) -$(MAKEFLAGS) -f makefile.vc TCLDIR=$(ROOT) test &\ + popd \ + ) + +install-pkgs: + @for /d %d in ($(PKGSDIR)\*) do \ + @if exist "%~fd\win\makefile.vc" ( \ + pushd "%~fd\win" & \ + $(MAKE) -$(MAKEFLAGS) -f makefile.vc TCLDIR=$(ROOT) install &\ + popd \ + ) + +clean-pkgs: + @for /d %d in ($(PKGSDIR)\*) do \ + @if exist "%~fd\win\makefile.vc" ( \ + pushd "%~fd\win" & \ + $(MAKE) -$(MAKEFLAGS) -f makefile.vc TCLDIR=$(ROOT) clean &\ + popd \ + ) + +$(CAT32): $(WINDIR)\cat.c + $(cc32) $(CON_CFLAGS) -Fo$(TMP_DIR)\ $? + $(link32) $(conlflags) -out:$@ -stack:16384 $(TMP_DIR)\cat.obj \ + $(baselibs) + $(_VC_MANIFEST_EMBED_EXE) + +#--------------------------------------------------------------------- +# Regenerate the stubs files. [Development use only] +#--------------------------------------------------------------------- + +genstubs: +!if !exist($(TCLSH)) + @echo Build tclsh first! +!else + $(TCLSH) $(TOOLSDIR:\=/)/genStubs.tcl $(GENERICDIR:\=/) \ + $(GENERICDIR:\=/)/tcl.decls $(GENERICDIR:\=/)/tclInt.decls \ + $(GENERICDIR:\=/)/tclTomMath.decls + $(TCLSH) $(TOOLSDIR:\=/)/genStubs.tcl $(GENERICDIR:\=/) \ + $(GENERICDIR:\=/)/tclOO.decls +!endif + + +#---------------------------------------------------------------------- +# The following target generates the file generic/tclTomMath.h. +# It needs to be run (and the results checked) after updating +# to a new release of libtommath. +#---------------------------------------------------------------------- + +gentommath_h: +!if !exist($(TCLSH)) + @echo Build tclsh first! +!else + $(TCLSH) "$(TOOLSDIR:\=/)/fix_tommath_h.tcl" \ + "$(TOMMATHDIR:\=/)/tommath.h" \ + > "$(GENERICDIR)\tclTomMath.h" +!endif + +#--------------------------------------------------------------------- +# Build the Windows HTML help file. +#--------------------------------------------------------------------- + +# NOTE: you can define HHC on the command-line to override this +!ifndef HHC +HHC=""%ProgramFiles%\HTML Help Workshop\hhc.exe"" +!endif +HTMLDIR=$(OUT_DIR)\html +HTMLBASE=TclTk$(VERSION) +HHPFILE=$(HTMLDIR)\$(HTMLBASE).hhp +CHMFILE=$(HTMLDIR)\$(HTMLBASE).chm + +htmlhelp: chmsetup $(CHMFILE) + +$(CHMFILE): $(DOCDIR)\* + @$(TCLSH) $(TOOLSDIR)\tcltk-man2html.tcl "--htmldir=$(HTMLDIR)" + @echo Compiling HTML help project + -$(HHC) <<$(HHPFILE) >NUL +[OPTIONS] +Compatibility=1.1 or later +Compiled file=$(HTMLBASE).chm +Default topic=contents.htm +Display compile progress=no +Error log file=$(HTMLBASE).log +Full-text search=Yes +Language=0x409 English (United States) +Title=Tcl/Tk $(DOT_VERSION) Help +[FILES] +contents.htm +docs.css +Keywords\*.htm +TclCmd\*.htm +TclLib\*.htm +TkCmd\*.htm +TkLib\*.htm +UserCmd\*.htm +<< + +chmsetup: + @if not exist $(HTMLDIR)\nul mkdir $(HTMLDIR) + +#------------------------------------------------------------------------- +# Build the old-style Windows .hlp file +#------------------------------------------------------------------------- + +TCLHLPBASE = $(PROJECT)$(VERSION) +HELPFILE = $(OUT_DIR)\$(TCLHLPBASE).hlp +HELPCNT = $(OUT_DIR)\$(TCLHLPBASE).cnt +DOCTMP_DIR = $(OUT_DIR)\$(PROJECT)_docs +HELPRTF = $(DOCTMP_DIR)\$(PROJECT).rtf +MAN2HELP = $(DOCTMP_DIR)\man2help.tcl +MAN2HELP2 = $(DOCTMP_DIR)\man2help2.tcl +INDEX = $(DOCTMP_DIR)\index.tcl +BMP = $(DOCTMP_DIR)\feather.bmp +BMP_NOPATH = feather.bmp +MAN2TCL = $(DOCTMP_DIR)\man2tcl.exe + +winhelp: docsetup $(HELPFILE) + +docsetup: + @if not exist $(DOCTMP_DIR)\nul mkdir $(DOCTMP_DIR) + +$(MAN2HELP) $(MAN2HELP2) $(INDEX) $(BMP): $(TOOLSDIR)\$$(@F) + @$(CPY) $(TOOLSDIR)\$(@F) $(@D) + +$(HELPFILE): $(HELPRTF) $(BMP) + cd $(DOCTMP_DIR) + start /wait hcrtf.exe -x <<$(PROJECT).hpj +[OPTIONS] +COMPRESS=12 Hall Zeck +LCID=0x409 0x0 0x0 ; English (United States) +TITLE=Tcl/Tk Reference Manual +BMROOT=. +CNT=$(@B).cnt +HLP=$(@B).hlp + +[FILES] +$(PROJECT).rtf + +[WINDOWS] +main="Tcl/Tk Reference Manual",,27648,(r15263976),(r65535) + +[CONFIG] +BrowseButtons() +CreateButton(1, "Web", ExecFile("http://www.tcl.tk")) +CreateButton(2, "SF", ExecFile("http://sf.net/projects/tcl")) +CreateButton(3, "Wiki", ExecFile("http://wiki.tcl.tk")) +CreateButton(4, "FAQ", ExecFile("http://www.purl.org/NET/Tcl-FAQ/")) +<< + cd $(MAKEDIR) + @$(CPY) "$(DOCTMP_DIR)\$(@B).hlp" "$(OUT_DIR)" + @$(CPY) "$(DOCTMP_DIR)\$(@B).cnt" "$(OUT_DIR)" + +$(MAN2TCL): $(TOOLSDIR)\$$(@B).c + $(cc32) $(TCL_CFLAGS) -Fo$(@D)\ $(TOOLSDIR)\$(@B).c + $(link32) $(conlflags) -out:$@ -stack:16384 $(@D)\man2tcl.obj + $(_VC_MANIFEST_EMBED_EXE) + +$(HELPRTF): $(MAN2TCL) $(MAN2HELP) $(MAN2HELP2) $(INDEX) $(DOCDIR)\* + $(TCLSH) $(MAN2HELP) -bitmap $(BMP_NOPATH) $(PROJECT) $(VERSION) $(DOCDIR:\=/) + +install-docs: +!if exist("$(CHMFILE)") + @echo Installing compiled HTML help + @$(CPY) "$(CHMFILE)" "$(DOC_INSTALL_DIR)\" +!endif +!if exist("$(HELPFILE)") + @echo Installing Windows help + @$(CPY) "$(HELPFILE)" "$(DOC_INSTALL_DIR)\" + @$(CPY) "$(HELPCNT)" "$(DOC_INSTALL_DIR)\" +!endif + +#--------------------------------------------------------------------- +# Build tclConfig.sh for the TEA build system. +#--------------------------------------------------------------------- + +tclConfig: $(OUT_DIR)\tclConfig.sh + +$(OUT_DIR)\tclConfig.sh: $(WINDIR)\tclConfig.sh.in + @echo Creating tclConfig.sh + @nmakehlp -s << $** >$@ +@TCL_DLL_FILE@ $(TCLLIBNAME) +@TCL_VERSION@ $(DOTVERSION) +@TCL_MAJOR_VERSION@ $(TCL_MAJOR_VERSION) +@TCL_MINOR_VERSION@ $(TCL_MINOR_VERSION) +@TCL_PATCH_LEVEL@ $(TCL_PATCH_LEVEL) +@CC@ $(CC) +@DEFS@ $(TCL_CFLAGS) +@CFLAGS_DEBUG@ -nologo -c -W3 -YX -Fp$(TMP_DIR)\ -MDd +@CFLAGS_OPTIMIZE@ -nologo -c -W3 -YX -Fp$(TMP_DIR)\ -MD +@LDFLAGS_DEBUG@ -nologo -machine:$(MACHINE) -debug -debugtype:cv +@LDFLAGS_OPTIMIZE@ -nologo -machine:$(MACHINE) -release -opt:ref -opt:icf,3 +@TCL_DBGX@ $(SUFX) +@TCL_LIB_FILE@ $(PROJECT)$(VERSION)$(SUFX).lib +@TCL_NEEDS_EXP_FILE@ +@LIBS@ $(baselibs) +@prefix@ $(_INSTALLDIR) +@exec_prefix@ $(BIN_INSTALL_DIR) +@SHLIB_CFLAGS@ +@STLIB_CFLAGS@ +@CFLAGS_WARNING@ -W3 +@EXTRA_CFLAGS@ -YX +@SHLIB_LD@ $(link32) $(dlllflags) +@STLIB_LD@ $(lib32) -nologo +@SHLIB_LD_LIBS@ $(baselibs) +@SHLIB_SUFFIX@ .dll +@DL_LIBS@ +@LDFLAGS@ +@TCL_CC_SEARCH_FLAGS@ +@TCL_LD_SEARCH_FLAGS@ +@LIBOBJS@ +@RANLIB@ +@TCL_LIB_FLAG@ +@TCL_BUILD_LIB_SPEC@ +@TCL_LIB_SPEC@ $(LIB_INSTALL_DIR)\$(PROJECT)$(VERSION)$(SUFX).lib +@TCL_INCLUDE_SPEC@ -I$(INCLUDE_INSTALL_DIR) +@TCL_LIB_VERSIONS_OK@ +@TCL_SRC_DIR@ $(ROOT) +@TCL_PACKAGE_PATH@ +@TCL_STUB_LIB_FILE@ $(TCLSTUBLIBNAME) +@TCL_STUB_LIB_FLAG@ $(TCLSTUBLIBNAME) +@TCL_STUB_LIB_SPEC@ -L$(LIB_INSTALL_DIR) $(TCLSTUBLIBNAME) +@TCL_THREADS@ $(TCL_THREADS) +@TCL_BUILD_STUB_LIB_SPEC@ -L$(OUT_DIR) $(TCLSTUBLIBNAME) +@TCL_BUILD_STUB_LIB_PATH@ $(TCLSTUBLIB) +@TCL_STUB_LIB_PATH@ $(LIB_INSTALL_DIR)\$(TCLSTUBLIBNAME) +@CFG_TCL_EXPORT_FILE_SUFFIX@ $(VERSION)$(SUFX).lib +@CFG_TCL_SHARED_LIB_SUFFIX@ $(VERSION)$(SUFX).dll +@CFG_TCL_UNSHARED_LIB_SUFFIX@ $(VERSION)$(SUFX).lib +!if $(STATIC_BUILD) +@TCL_SHARED_BUILD@ 0 +!else +@TCL_SHARED_BUILD@ 1 +!endif +<< + + +#--------------------------------------------------------------------- +# The following target generates the file generic/tclDate.c +# from the yacc grammar found in generic/tclGetDate.y. This is +# only run by hand as yacc is not available in all environments. +# The name of the .c file is different than the name of the .y file +# so that make doesn't try to automatically regenerate the .c file. +#--------------------------------------------------------------------- + +gendate: + bison --output-file=$(GENERICDIR)/tclDate.c \ + --name-prefix=TclDate \ + $(GENERICDIR)/tclGetDate.y + +#--------------------------------------------------------------------- +# Special case object file targets +#--------------------------------------------------------------------- + +$(TMP_DIR)\testMain.obj: $(WINDIR)\tclAppInit.c + $(cc32) $(TCL_CFLAGS) -DTCL_TEST \ + -DTCL_USE_STATIC_PACKAGES=$(TCL_USE_STATIC_PACKAGES) \ + -Fo$@ $? + +$(TMP_DIR)\tclMain2.obj: $(GENERICDIR)\tclMain.c + $(cc32) $(TCL_CFLAGS) -DBUILD_tcl -DTCL_ASCII_MAIN \ + -Fo$@ $? + +$(TMP_DIR)\tclTest.obj: $(GENERICDIR)\tclTest.c + $(cc32) $(TCL_CFLAGS) -Fo$@ $? + +$(TMP_DIR)\tclTestObj.obj: $(GENERICDIR)\tclTestObj.c + $(cc32) $(TCL_CFLAGS) -Fo$@ $? + +$(TMP_DIR)\tclWinTest.obj: $(WINDIR)\tclWinTest.c + $(cc32) $(TCL_CFLAGS) -Fo$@ $? + +$(TMP_DIR)\tclZlib.obj: $(GENERICDIR)\tclZlib.c + $(cc32) $(TCL_CFLAGS) -I$(COMPATDIR)\zlib -DBUILD_tcl -Fo$@ $? + +$(TMP_DIR)\tclPkgConfig.obj: $(GENERICDIR)\tclPkgConfig.c + $(cc32) -DBUILD_tcl $(TCL_CFLAGS) \ + -DCFG_INSTALL_LIBDIR="\"$(LIB_INSTALL_DIR:\=\\)\"" \ + -DCFG_INSTALL_BINDIR="\"$(BIN_INSTALL_DIR:\=\\)\"" \ + -DCFG_INSTALL_SCRDIR="\"$(SCRIPT_INSTALL_DIR:\=\\)\"" \ + -DCFG_INSTALL_INCDIR="\"$(INCLUDE_INSTALL_DIR:\=\\)\"" \ + -DCFG_INSTALL_DOCDIR="\"$(DOC_INSTALL_DIR:\=\\)\"" \ + -DCFG_RUNTIME_LIBDIR="\"$(LIB_INSTALL_DIR:\=\\)\"" \ + -DCFG_RUNTIME_BINDIR="\"$(BIN_INSTALL_DIR:\=\\)\"" \ + -DCFG_RUNTIME_SCRDIR="\"$(SCRIPT_INSTALL_DIR:\=\\)\"" \ + -DCFG_RUNTIME_INCDIR="\"$(INCLUDE_INSTALL_DIR:\=\\)\"" \ + -DCFG_RUNTIME_DOCDIR="\"$(DOC_INSTALL_DIR:\=\\)\"" \ + -Fo$@ $? + +$(TMP_DIR)\tclAppInit.obj: $(WINDIR)\tclAppInit.c + $(cc32) $(TCL_CFLAGS) \ + -DTCL_USE_STATIC_PACKAGES=$(TCL_USE_STATIC_PACKAGES) \ + -Fo$@ $? + +### The following objects should be built using the stub interfaces +### *ALL* extensions need to built with -DTCL_THREADS=1 + +$(TMP_DIR)\tclWinReg.obj: $(WINDIR)\tclWinReg.c +!if $(STATIC_BUILD) + $(cc32) $(TCL_CFLAGS) -DTCL_THREADS=1 -DSTATIC_BUILD -Fo$@ $? +!else + $(cc32) $(TCL_CFLAGS) -DTCL_THREADS=1 -DUSE_TCL_STUBS -Fo$@ $? +!endif + + +$(TMP_DIR)\tclWinDde.obj: $(WINDIR)\tclWinDde.c +!if $(STATIC_BUILD) + $(cc32) $(TCL_CFLAGS) -DTCL_THREADS=1 -DSTATIC_BUILD -Fo$@ $? +!else + $(cc32) $(TCL_CFLAGS) -DTCL_THREADS=1 -DUSE_TCL_STUBS -Fo$@ $? +!endif + + +### The following objects are part of the stub library and should not +### be built as DLL objects. -Zl is used to avoid a dependency on any +### specific C run-time. + +$(TMP_DIR)\tclStubLib.obj: $(GENERICDIR)\tclStubLib.c + $(cc32) $(STUB_CFLAGS) -Zl -DSTATIC_BUILD $(TCL_INCLUDES) -Fo$@ $? + +$(TMP_DIR)\tclTomMathStubLib.obj: $(GENERICDIR)\tclTomMathStubLib.c + $(cc32) $(STUB_CFLAGS) -Zl -DSTATIC_BUILD $(TCL_INCLUDES) -Fo$@ $? + +$(TMP_DIR)\tclOOStubLib.obj: $(GENERICDIR)\tclOOStubLib.c + $(cc32) $(STUB_CFLAGS) -Zl -DSTATIC_BUILD $(TCL_INCLUDES) -Fo$@ $? + +$(TMP_DIR)\tclsh.exe.manifest: $(WINDIR)\tclsh.exe.manifest.in + @nmakehlp -s << $** >$@ +@MACHINE@ $(MACHINE:IX86=X86) +@TCL_WIN_VERSION@ $(DOTVERSION).0.0 +<< + +#--------------------------------------------------------------------- +# Generate the source dependencies. Having dependency rules will +# improve incremental build accuracy without having to resort to a +# full rebuild just because some non-global header file like +# tclCompile.h was changed. These rules aren't needed when building +# from scratch. +#--------------------------------------------------------------------- + +depend: +!if !exist($(TCLSH)) + @echo Build tclsh first! +!else + $(TCLSH) $(TOOLSDIR:\=/)/mkdepend.tcl -vc32 -out:"$(OUT_DIR)\depend.mk" \ + -passthru:"-DBUILD_tcl $(TCL_INCLUDES)" $(GENERICDIR),$$(GENERICDIR) \ + $(COMPATDIR),$$(COMPATDIR) $(TOMMATHDIR),$$(TOMMATHDIR) $(WINDIR),$$(WINDIR) @<< +$(TCLOBJS) +<< +!endif + +#--------------------------------------------------------------------- +# Dependency rules +#--------------------------------------------------------------------- + +!if exist("$(OUT_DIR)\depend.mk") +!include "$(OUT_DIR)\depend.mk" +!message *** Dependency rules in use. +!else +!message *** Dependency rules are not being used. +!endif + +### add a spacer in the output +!message + + +#--------------------------------------------------------------------- +# Implicit rules. A limitation exists with nmake that requires that +# source directory can not contain spaces in the path. This an +# absolute. +#--------------------------------------------------------------------- + +{$(WINDIR)}.c{$(TMP_DIR)}.obj:: + $(cc32) $(TCL_CFLAGS) -DBUILD_tcl -Fo$(TMP_DIR)\ @<< +$< +<< + +{$(TOMMATHDIR)}.c{$(TMP_DIR)}.obj:: + $(cc32) $(TCL_CFLAGS) -DBUILD_tcl -Fo$(TMP_DIR)\ @<< +$< +<< + +{$(GENERICDIR)}.c{$(TMP_DIR)}.obj:: + $(cc32) $(TCL_CFLAGS) -DBUILD_tcl -Fo$(TMP_DIR)\ @<< +$< +<< + +{$(COMPATDIR)}.c{$(TMP_DIR)}.obj:: + $(cc32) $(TCL_CFLAGS) -DBUILD_tcl -Fo$(TMP_DIR)\ @<< +$< +<< + +{$(COMPATDIR)\zlib}.c{$(TMP_DIR)}.obj:: + $(cc32) $(TCL_CFLAGS) -DBUILD_tcl -Fo$(TMP_DIR)\ @<< +$< +<< + +{$(WINDIR)}.rc{$(TMP_DIR)}.res: + $(rc32) -fo $@ -r -i "$(GENERICDIR)" -i "$(TMP_DIR)" \ + -d DEBUG=$(DEBUG) -d UNCHECKED=$(UNCHECKED) \ + -d TCL_THREADS=$(TCL_THREADS) \ + -d STATIC_BUILD=$(STATIC_BUILD) \ + $< + +$(TMP_DIR)\tclsh.res: $(TMP_DIR)\tclsh.exe.manifest + +.SUFFIXES: +.SUFFIXES:.c .rc + + +#--------------------------------------------------------------------- +# Installation. +#--------------------------------------------------------------------- + +install-binaries: + @echo Installing to '$(_INSTALLDIR)' + @echo Installing $(TCLLIBNAME) +!if "$(TCLLIB)" != "$(TCLIMPLIB)" + @$(CPY) "$(TCLLIB)" "$(BIN_INSTALL_DIR)\" +!endif + @$(CPY) "$(TCLIMPLIB)" "$(LIB_INSTALL_DIR)\" +!if exist($(TCLSH)) + @echo Installing $(TCLSHNAME) + @$(CPY) "$(TCLSH)" "$(BIN_INSTALL_DIR)\" +!endif + @echo Installing $(TCLSTUBLIBNAME) + @$(CPY) "$(TCLSTUBLIB)" "$(LIB_INSTALL_DIR)\" + +#" emacs fix + +install-libraries: tclConfig install-msgs install-tzdata + @if not exist "$(SCRIPT_INSTALL_DIR)$(NULL)" \ + $(MKDIR) "$(SCRIPT_INSTALL_DIR)" + @if not exist "$(SCRIPT_INSTALL_DIR)\..\tcl8$(NULL)" \ + $(MKDIR) "$(SCRIPT_INSTALL_DIR)\..\tcl8" + @if not exist "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.4$(NULL)" \ + $(MKDIR) "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.4" + @if not exist "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.4\platform$(NULL)" \ + $(MKDIR) "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.4\platform" + @if not exist "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.5$(NULL)" \ + $(MKDIR) "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.5" + @if not exist "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.6$(NULL)" \ + $(MKDIR) "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.6" + @echo Installing header files + @$(CPY) "$(GENERICDIR)\tcl.h" "$(INCLUDE_INSTALL_DIR)\" + @$(CPY) "$(GENERICDIR)\tclDecls.h" "$(INCLUDE_INSTALL_DIR)\" + @$(CPY) "$(GENERICDIR)\tclOO.h" "$(INCLUDE_INSTALL_DIR)\" + @$(CPY) "$(GENERICDIR)\tclOODecls.h" "$(INCLUDE_INSTALL_DIR)\" + @$(CPY) "$(GENERICDIR)\tclPlatDecls.h" "$(INCLUDE_INSTALL_DIR)\" + @$(CPY) "$(GENERICDIR)\tclTomMath.h" "$(INCLUDE_INSTALL_DIR)\" + @$(CPY) "$(GENERICDIR)\tclTomMathDecls.h" "$(INCLUDE_INSTALL_DIR)\" + @$(CPY) "$(TOMMATHDIR)\tommath_class.h" "$(INCLUDE_INSTALL_DIR)\" + @$(CPY) "$(TOMMATHDIR)\tommath_superclass.h" "$(INCLUDE_INSTALL_DIR)\" + @echo Installing library files to $(SCRIPT_INSTALL_DIR) + @$(CPY) "$(ROOT)\library\history.tcl" "$(SCRIPT_INSTALL_DIR)\" + @$(CPY) "$(ROOT)\library\init.tcl" "$(SCRIPT_INSTALL_DIR)\" + @$(CPY) "$(ROOT)\library\clock.tcl" "$(SCRIPT_INSTALL_DIR)\" + @$(CPY) "$(ROOT)\library\tm.tcl" "$(SCRIPT_INSTALL_DIR)\" + @$(CPY) "$(ROOT)\library\parray.tcl" "$(SCRIPT_INSTALL_DIR)\" + @$(CPY) "$(ROOT)\library\safe.tcl" "$(SCRIPT_INSTALL_DIR)\" + @$(CPY) "$(ROOT)\library\tclIndex" "$(SCRIPT_INSTALL_DIR)\" + @$(CPY) "$(ROOT)\library\package.tcl" "$(SCRIPT_INSTALL_DIR)\" + @$(CPY) "$(ROOT)\library\word.tcl" "$(SCRIPT_INSTALL_DIR)\" + @$(CPY) "$(ROOT)\library\auto.tcl" "$(SCRIPT_INSTALL_DIR)\" + @$(CPY) "$(OUT_DIR)\tclConfig.sh" "$(LIB_INSTALL_DIR)\" + @$(CPY) "$(WINDIR)\tclooConfig.sh" "$(LIB_INSTALL_DIR)\" + @echo Installing library http1.0 directory + @$(CPY) "$(ROOT)\library\http1.0\*.tcl" \ + "$(SCRIPT_INSTALL_DIR)\http1.0\" + @echo Installing library opt0.4 directory + @$(CPY) "$(ROOT)\library\opt\*.tcl" \ + "$(SCRIPT_INSTALL_DIR)\opt0.4\" + @echo Installing package http $(PKG_HTTP_VER) as a Tcl Module + @$(COPY) "$(ROOT)\library\http\http.tcl" \ + "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.6\http-$(PKG_HTTP_VER).tm" + @echo Installing package msgcat $(PKG_MSGCAT_VER) as a Tcl Module + @$(COPY) "$(ROOT)\library\msgcat\msgcat.tcl" \ + "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.5\msgcat-$(PKG_MSGCAT_VER).tm" + @echo Installing package tcltest $(PKG_TCLTEST_VER) as a Tcl Module + @$(COPY) "$(ROOT)\library\tcltest\tcltest.tcl" \ + "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.5\tcltest-$(PKG_TCLTEST_VER).tm" + @echo Installing package platform $(PKG_PLATFORM_VER) as a Tcl Module + @$(COPY) "$(ROOT)\library\platform\platform.tcl" \ + "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.4\platform-$(PKG_PLATFORM_VER).tm" + @echo Installing package platform::shell $(PKG_SHELL_VER) as a Tcl Module + @$(COPY) "$(ROOT)\library\platform\shell.tcl" \ + "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.4\platform\shell-$(PKG_SHELL_VER).tm" + @echo Installing $(TCLDDELIBNAME) +!if $(STATIC_BUILD) +!if !$(TCL_USE_STATIC_PACKAGES) + @$(CPY) "$(TCLDDELIB)" "$(LIB_INSTALL_DIR)\" +!endif +!else + @$(CPY) "$(TCLDDELIB)" "$(LIB_INSTALL_DIR)\dde$(DDEDOTVERSION)\" + @$(CPY) "$(ROOT)\library\dde\pkgIndex.tcl" \ + "$(LIB_INSTALL_DIR)\dde$(DDEDOTVERSION)\" +!endif + @echo Installing $(TCLREGLIBNAME) +!if $(STATIC_BUILD) +!if !$(TCL_USE_STATIC_PACKAGES) + @$(CPY) "$(TCLREGLIB)" "$(LIB_INSTALL_DIR)\" +!endif +!else + @$(CPY) "$(TCLREGLIB)" "$(LIB_INSTALL_DIR)\reg$(REGDOTVERSION)\" + @$(CPY) "$(ROOT)\library\reg\pkgIndex.tcl" \ + "$(LIB_INSTALL_DIR)\reg$(REGDOTVERSION)\" +!endif + @echo Installing encodings + @$(CPY) "$(ROOT)\library\encoding\*.enc" \ + "$(SCRIPT_INSTALL_DIR)\encoding\" + +#" emacs fix + +install-tzdata: + @echo Installing time zone data + @set TCL_LIBRARY=$(ROOT:\=/)/library + @$(TCLSH_NATIVE) "$(ROOT:\=/)/tools/installData.tcl" \ + "$(ROOT:\=/)/library/tzdata" "$(SCRIPT_INSTALL_DIR)/tzdata" + +install-msgs: + @echo Installing message catalogs + @set TCL_LIBRARY=$(ROOT:\=/)/library + @$(TCLSH_NATIVE) "$(ROOT:\=/)/tools/installData.tcl" \ + "$(ROOT:\=/)/library/msgs" "$(SCRIPT_INSTALL_DIR)/msgs" + +#--------------------------------------------------------------------- +# Clean up +#--------------------------------------------------------------------- + +tidy: +!if "$(TCLLIB)" != "$(TCLIMPLIB)" + @echo Removing $(TCLLIB) ... + @if exist $(TCLLIB) del $(TCLLIB) +!endif + @echo Removing $(TCLIMPLIB) ... + @if exist $(TCLIMPLIB) del $(TCLIMPLIB) + @echo Removing $(TCLSH) ... + @if exist $(TCLSH) del $(TCLSH) + @echo Removing $(TCLTEST) ... + @if exist $(TCLTEST) del $(TCLTEST) + @echo Removing $(TCLDDELIB) ... + @if exist $(TCLDDELIB) del $(TCLDDELIB) + @echo Removing $(TCLREGLIB) ... + @if exist $(TCLREGLIB) del $(TCLREGLIB) + +clean: clean-pkgs + @echo Cleaning $(TMP_DIR)\* ... + @if exist $(TMP_DIR)\nul $(RMDIR) $(TMP_DIR) + @echo Cleaning $(WINDIR)\nmakehlp.obj ... + @if exist $(WINDIR)\nmakehlp.obj del $(WINDIR)\nmakehlp.obj + @echo Cleaning $(WINDIR)\nmakehlp.exe ... + @if exist $(WINDIR)\nmakehlp.exe del $(WINDIR)\nmakehlp.exe + @echo Cleaning $(WINDIR)\nmhlp-out.txt ... + @if exist $(WINDIR)\nmhlp-out.txt del $(WINDIR)\nmhlp-out.txt + @echo Cleaning $(WINDIR)\_junk.pch ... + @if exist $(WINDIR)\_junk.pch del $(WINDIR)\_junk.pch + @echo Cleaning $(WINDIR)\vercl.x ... + @if exist $(WINDIR)\vercl.x del $(WINDIR)\vercl.x + @echo Cleaning $(WINDIR)\vercl.i ... + @if exist $(WINDIR)\vercl.i del $(WINDIR)\vercl.i + @echo Cleaning $(WINDIR)\versions.vc ... + @if exist $(WINDIR)\versions.vc del $(WINDIR)\versions.vc + +realclean: hose + +hose: + @echo Hosing $(OUT_DIR)\* ... + @if exist $(OUT_DIR)\nul $(RMDIR) $(OUT_DIR) + +# Local Variables: +# mode: makefile +# End: -- cgit v0.12 From 67a242e0031c5c5108446b9fc1801d8dec548e70 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 12 Mar 2018 13:48:35 +0000 Subject: msgcat 1.7 uses [tailcall], so requires Tcl 8.6. --- library/msgcat/msgcat.tcl | 2 +- library/msgcat/pkgIndex.tcl | 3 ++- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/library/msgcat/msgcat.tcl b/library/msgcat/msgcat.tcl index 33ff5cb..203a1bf 100644 --- a/library/msgcat/msgcat.tcl +++ b/library/msgcat/msgcat.tcl @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require Tcl 8.5- +package require Tcl 8.6- # When the version number changes, be sure to update the pkgIndex.tcl file, # and the installation directory in the Makefiles. package provide msgcat 1.7.0 diff --git a/library/msgcat/pkgIndex.tcl b/library/msgcat/pkgIndex.tcl index fe3b3a1..74a284f 100644 --- a/library/msgcat/pkgIndex.tcl +++ b/library/msgcat/pkgIndex.tcl @@ -1,2 +1,3 @@ -if {![package vsatisfies [package provide Tcl] 8.5-]} {return} +if {![package vsatisfies [package provide Tcl] 8.5]} {return} +if {![package vsatisfies [package provide Tcl] 8.6-]} {return} package ifneeded msgcat 1.7.0 [list source [file join $dir msgcat.tcl]] -- cgit v0.12 From f35817ce5a0a1eaf1e96e6e4c46aa3f744301221 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 12 Mar 2018 14:07:26 +0000 Subject: Undo setting of execute permissions. --- changes | 0 library/msgcat/msgcat.tcl | 0 library/msgcat/pkgIndex.tcl | 0 tests/msgcat.test | 0 unix/Makefile.in | 0 win/Makefile.in | 0 6 files changed, 0 insertions(+), 0 deletions(-) mode change 100755 => 100644 changes mode change 100755 => 100644 library/msgcat/msgcat.tcl mode change 100755 => 100644 library/msgcat/pkgIndex.tcl mode change 100755 => 100644 tests/msgcat.test mode change 100755 => 100644 unix/Makefile.in mode change 100755 => 100644 win/Makefile.in diff --git a/changes b/changes old mode 100755 new mode 100644 diff --git a/library/msgcat/msgcat.tcl b/library/msgcat/msgcat.tcl old mode 100755 new mode 100644 diff --git a/library/msgcat/pkgIndex.tcl b/library/msgcat/pkgIndex.tcl old mode 100755 new mode 100644 diff --git a/tests/msgcat.test b/tests/msgcat.test old mode 100755 new mode 100644 diff --git a/unix/Makefile.in b/unix/Makefile.in old mode 100755 new mode 100644 diff --git a/win/Makefile.in b/win/Makefile.in old mode 100755 new mode 100644 -- cgit v0.12 From 8bd4a8cf2c0d70bf09729c5f6b203b75f0e6fd52 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 12 Mar 2018 14:41:20 +0000 Subject: Revert change that broke usage with Tcl 9 --- library/msgcat/pkgIndex.tcl | 1 - 1 file changed, 1 deletion(-) diff --git a/library/msgcat/pkgIndex.tcl b/library/msgcat/pkgIndex.tcl index 74a284f..2feb9c6 100644 --- a/library/msgcat/pkgIndex.tcl +++ b/library/msgcat/pkgIndex.tcl @@ -1,3 +1,2 @@ -if {![package vsatisfies [package provide Tcl] 8.5]} {return} if {![package vsatisfies [package provide Tcl] 8.6-]} {return} package ifneeded msgcat 1.7.0 [list source [file join $dir msgcat.tcl]] -- cgit v0.12 From 2ae2445072e3f52e56fa916fae2fbb21ac5629d0 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 12 Mar 2018 15:57:54 +0000 Subject: msgcat 1.7.0 features need foundation of Tcl 8.7. --- library/msgcat/msgcat.tcl | 3 ++- library/msgcat/pkgIndex.tcl | 2 +- unix/Makefile.in | 2 +- win/Makefile.in | 2 +- win/makefile.vc | 2 +- 5 files changed, 6 insertions(+), 5 deletions(-) diff --git a/library/msgcat/msgcat.tcl b/library/msgcat/msgcat.tcl index 96b0110..50a9064 100644 --- a/library/msgcat/msgcat.tcl +++ b/library/msgcat/msgcat.tcl @@ -11,7 +11,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require Tcl 8.6- +# We use oo::define::self, which is new in Tcl 8.7 +package require Tcl 8.7- # When the version number changes, be sure to update the pkgIndex.tcl file, # and the installation directory in the Makefiles. package provide msgcat 1.7.0 diff --git a/library/msgcat/pkgIndex.tcl b/library/msgcat/pkgIndex.tcl index 2feb9c6..3309a30 100644 --- a/library/msgcat/pkgIndex.tcl +++ b/library/msgcat/pkgIndex.tcl @@ -1,2 +1,2 @@ -if {![package vsatisfies [package provide Tcl] 8.6-]} {return} +if {![package vsatisfies [package provide Tcl] 8.7-]} {return} package ifneeded msgcat 1.7.0 [list source [file join $dir msgcat.tcl]] diff --git a/unix/Makefile.in b/unix/Makefile.in index 9c9ee53..83a8aed 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -852,7 +852,7 @@ install-libraries: libraries $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/opt0.4; \ done; @echo "Installing package msgcat 1.7.0 as a Tcl Module"; - @$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.6/msgcat-1.7.0.tm; + @$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.7/msgcat-1.7.0.tm; @echo "Installing package tcltest 2.4.1 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.4.1.tm; diff --git a/win/Makefile.in b/win/Makefile.in index 1a72fc7..56ccb4d 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -661,7 +661,7 @@ install-libraries: libraries install-tzdata install-msgs $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/opt0.4"; \ done; @echo "Installing package msgcat 1.7.0 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.6/msgcat-1.7.0.tm; + @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.7/msgcat-1.7.0.tm; @echo "Installing package tcltest 2.4.0 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/tcltest-2.4.0.tm; @echo "Installing package platform 1.0.14 as a Tcl Module"; diff --git a/win/makefile.vc b/win/makefile.vc index 11b15a3..7ed4c63 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -869,7 +869,7 @@ install-libraries: tclConfig tcl-nmake install-msgs install-tzdata "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.6\http-$(PKG_HTTP_VER).tm" @echo Installing package msgcat $(PKG_MSGCAT_VER) as a Tcl Module @$(COPY) "$(ROOT)\library\msgcat\msgcat.tcl" \ - "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.5\msgcat-$(PKG_MSGCAT_VER).tm" + "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.7\msgcat-$(PKG_MSGCAT_VER).tm" @echo Installing package tcltest $(PKG_TCLTEST_VER) as a Tcl Module @$(COPY) "$(ROOT)\library\tcltest\tcltest.tcl" \ "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.5\tcltest-$(PKG_TCLTEST_VER).tm" -- cgit v0.12 From 23178bb2087e384cb320634e4974b3dc6104eb89 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 13 Mar 2018 03:15:28 +0000 Subject: Tidy up and comment [string replace] and its corner cases. --- generic/tclCmdMZ.c | 29 +++++++++++++++++++++-------- tests/string.test | 6 ++++++ 2 files changed, 27 insertions(+), 8 deletions(-) diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 30586b1..706d71c 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -2262,7 +2262,7 @@ StringRplcCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_UniChar *ustring; - int first, last, length; + int first, last, length, end; if (objc < 4 || objc > 5) { Tcl_WrongNumArgs(interp, 1, objv, "string first last ?string?"); @@ -2270,20 +2270,33 @@ StringRplcCmd( } ustring = Tcl_GetUnicodeFromObj(objv[1], &length); - length--; + end = length - 1; - if (TclGetIntForIndexM(interp, objv[2], length, &first) != TCL_OK || - TclGetIntForIndexM(interp, objv[3], length, &last) != TCL_OK){ + if (TclGetIntForIndexM(interp, objv[2], end, &first) != TCL_OK || + TclGetIntForIndexM(interp, objv[3], end, &last) != TCL_OK){ return TCL_ERROR; } - if ((last < first) || (last < 0) || (first > length)) { + /* + * The following test screens out most empty substrings as + * candidates for replacement. When they are detected, no + * replacement is done, and the result is the original string, + */ + if ((last < 0) || /* Range ends before start of string */ + (first > end) || /* Range begins after end of string */ + (last < first)) { /* Range begins after it starts */ + + /* + * BUT!!! when (end < 0) -- an empty original string -- we can + * have (first <= end < 0 <= last) and an empty string is permitted + * to be replaced. + */ Tcl_SetObjResult(interp, objv[1]); } else { Tcl_Obj *resultPtr; ustring = Tcl_GetUnicodeFromObj(objv[1], &length); - length--; + end = length-1; if (first < 0) { first = 0; @@ -2293,9 +2306,9 @@ StringRplcCmd( if (objc == 5) { Tcl_AppendObjToObj(resultPtr, objv[4]); } - if (last < length) { + if (last < end) { Tcl_AppendUnicodeToObj(resultPtr, ustring + last + 1, - length - last); + end - last); } Tcl_SetObjResult(interp, resultPtr); } diff --git a/tests/string.test b/tests/string.test index 39abd86..f3bb366 100644 --- a/tests/string.test +++ b/tests/string.test @@ -1294,6 +1294,12 @@ test string-14.16 {string replace} { test string-14.17 {string replace} { string replace abcdefghijklmnop end end-1 } {abcdefghijklmnop} +test string-14.18 {string replace} { + string replace abcdefghijklmnop 10 9 XXX +} {abcdefghijklmnop} +test string-14.19 {string replace} { + string replace {} -1 0 A +} A test string-15.1 {string tolower too few args} { list [catch {string tolower} msg] $msg -- cgit v0.12 From debafda1e72e4b9c63b64dce27e4948c7f448ebc Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 13 Mar 2018 04:01:03 +0000 Subject: Repair the INST_STR_REPLACE instruction. --- generic/tclExecute.c | 25 ++++++++++++++----------- 1 file changed, 14 insertions(+), 11 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index ef64ac1..2ef627d 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -5701,18 +5701,18 @@ TEBCresume( { Tcl_UniChar *ustring1, *ustring2, *ustring3, *end, *p; - int length3; + int length3, endIdx; Tcl_Obj *value3Ptr; case INST_STR_REPLACE: value3Ptr = POP_OBJECT(); valuePtr = OBJ_AT_DEPTH(2); - length = Tcl_GetCharLength(valuePtr) - 1; + endIdx = Tcl_GetCharLength(valuePtr) - 1; TRACE(("\"%.20s\" %s %s \"%.20s\" => ", O2S(valuePtr), O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), O2S(value3Ptr))); - if (TclGetIntForIndexM(interp, OBJ_UNDER_TOS, length, + if (TclGetIntForIndexM(interp, OBJ_UNDER_TOS, endIdx, &fromIdx) != TCL_OK - || TclGetIntForIndexM(interp, OBJ_AT_TOS, length, + || TclGetIntForIndexM(interp, OBJ_AT_TOS, endIdx, &toIdx) != TCL_OK) { TclDecrRefCount(value3Ptr); TRACE_ERROR(interp); @@ -5722,21 +5722,24 @@ TEBCresume( (void) POP_OBJECT(); TclDecrRefCount(OBJ_AT_TOS); (void) POP_OBJECT(); - if (fromIdx < 0) { - fromIdx = 0; - } - if (fromIdx > toIdx || fromIdx > length) { + if ((toIdx < 0) || + (fromIdx > endIdx) || + (toIdx < fromIdx)) { TRACE_APPEND(("\"%.30s\"\n", O2S(valuePtr))); TclDecrRefCount(value3Ptr); NEXT_INST_F(1, 0, 0); } - if (toIdx > length) { - toIdx = length; + if (fromIdx < 0) { + fromIdx = 0; + } + + if (toIdx > endIdx) { + toIdx = endIdx; } - if (fromIdx == 0 && toIdx == length) { + if (fromIdx == 0 && toIdx == endIdx) { TclDecrRefCount(OBJ_AT_TOS); OBJ_AT_TOS = value3Ptr; TRACE_APPEND(("\"%.30s\"\n", O2S(value3Ptr))); -- cgit v0.12 From 962427e8cd982fd685ca30f221083da2e7b62cea Mon Sep 17 00:00:00 2001 From: oehhar Date: Tue, 13 Mar 2018 14:53:16 +0000 Subject: tip490 oo for msgcat: added documentation --- changes | 2 +- doc/msgcat.n | 107 +++++++++++++++++++++++++++++++++++++++++++--- library/msgcat/msgcat.tcl | 4 +- 3 files changed, 103 insertions(+), 10 deletions(-) diff --git a/changes b/changes index feed968..01d4c7a 100644 --- a/changes +++ b/changes @@ -8882,5 +8882,5 @@ in this changeset (new minor version) rather than bug fixes: 2018-03-12 (TIP 490) add oo support for msgcat => msgcat 1.7.0 (oehlmann) -2018-03-12 (TIP 499) custom locale preference list (nijtmans) +2018-03-12 (TIP 499) custom locale preference list (oehlmann) => msgcat 1.7.0 diff --git a/doc/msgcat.n b/doc/msgcat.n index 2fc1eee..fbea20f 100644 --- a/doc/msgcat.n +++ b/doc/msgcat.n @@ -11,9 +11,9 @@ .SH NAME msgcat \- Tcl message catalog .SH SYNOPSIS -\fBpackage require Tcl 8.5\fR +\fBpackage require Tcl 8.7\fR .sp -\fBpackage require msgcat 1.6\fR +\fBpackage require msgcat 1.7\fR .sp \fB::msgcat::mc \fIsrc-string\fR ?\fIarg arg ...\fR? .sp @@ -23,6 +23,10 @@ msgcat \- Tcl message catalog \fB::msgcat::mcexists\fR ?\fB-exactnamespace\fR? ?\fB-exactlocale\fR? \fIsrc-string\fR .VE "TIP 412" .sp +.VS "TIP 490" +\fB::msgcat::mcpackagenamespaceget\fR +.VE "TIP 490" +.sp \fB::msgcat::mclocale \fR?\fInewLocale\fR? .sp \fB::msgcat::mcpreferences\fR @@ -71,6 +75,11 @@ In \fBmsgcat\fR, there is a global locale initialized by the system locale of th Each package may decide to use the global locale or to use a package specific locale. .PP The global locale may be changed on demand, for example by a user initiated language change or within a multi user application like a web server. +.PP +.VS tip490 +Object oriented programming is supported by the use of a package namespace. +.VE tip490 +.PP .SH COMMANDS .TP \fB::msgcat::mc \fIsrc-string\fR ?\fIarg arg ...\fR? @@ -95,6 +104,17 @@ use the result. If an application is written for a single language in this fashion, then it is easy to add support for additional languages later simply by defining new message catalog entries. .RE +.VS "TIP 490" +.TP +\fB::msgcat::mcn \fInamespace\fR \fIsrc-string\fR ?\fIarg arg ...\fR? +. +Like \fB::msgcat::mc\fR, but with the message namespace specified as first argument. +.PP +.RS +\fBmcn\fR may be used for cases where the package namespace is not the namespace of the caller. +An example is shown within the description of the command \fB::msgcat::mcpackagenamespaceget\fR below. +.RE +.PP .TP \fB::msgcat::mcmax ?\fIsrc-string src-string ...\fR? . @@ -103,17 +123,49 @@ of the longest translated string. This is useful when designing localized GUIs, which may require that all buttons, for example, be a fixed width (which will be the width of the widest button). .TP -\fB::msgcat::mcexists\fR ?\fB-exactnamespace\fR? ?\fB-exactlocale\fR? \fIsrc-string\fR -. .VS "TIP 412" +\fB::msgcat::mcexists\fR ?\fB-exactnamespace\fR? ?\fB-exactlocale\fR? ?\fB-namespace\fR \fInamespace\fR? \fIsrc-string\fR +. Return true, if there is a translation for the given \fIsrc-string\fR. .PP .RS The search may be limited by the option \fB\-exactnamespace\fR to only check the current namespace and not any parent namespaces. .PP It may also be limited by the option \fB\-exactlocale\fR to only check the first prefered locale (e.g. first element returned by \fB::msgcat::mcpreferences\fR if global locale is used). -.RE +.PP .VE "TIP 412" +.VS "TIP 490" +An explicit package namespace may be specified by the option \fB-namespace\fR. +The namespace of the caller is used if not explicitly specified. +.RE +.PP +.VE "TIP 490" +.VS "TIP 490" +.TP +\fB::msgcat::mcpackagenamespaceget\fR +. +Return the package namespace of the caller. +This command handles all cases described in section \fBObject oriented programming\fR. +.PP +.RS +Example usage is a tooltip package, which saves the caller package namespace to update the translation each time the tooltip is shown: +.CS +proc ::tooltip::tooltip {widget message} { + ... + set messagenamespace [uplevel 1 {::msgcat::mcpackagenamespaceget}] + ... + bind $widget [list ::tooltip::show $widget $messagenamespace $message] +} + +proc ::tooltip::show {widget messagenamespace message} { + ... + set message [::msgcat::mcn $messagenamespace $message] + ... +} +.CE +.RE +.PP +.VE "TIP 490" .TP \fB::msgcat::mclocale \fR?\fInewLocale\fR? . @@ -563,7 +615,7 @@ A generic unknown handler is used if set to the empty string. This consists in r See section \fBcallback invocation\fR below. The appended arguments are identical to \fB::msgcat::mcunknown\fR. .RE -.SS Callback invocation +.SH Callback invocation A package may decide to register one or multiple callbacks, as described above. .PP Callbacks are invoked, if: @@ -577,7 +629,48 @@ Callbacks are invoked, if: If a called routine fails with an error, the \fBbgerror\fR routine for the interpreter is invoked after command completion. Only exception is the callback \fBunknowncmd\fR, where an error causes the invoking \fBmc\fR-command to fail with that error. .PP -.SS Examples +.VS tip490 +.SH Object oriented programming +\fBmsgcat\fR supports packages implemented by object oriented programming. +Objects and classes should be defined within a package namespace. +.PP +There are 3 supported cases where package namespace sensitive commands of msgcat (\fBmc\fR, \fBmcexists\fR, \fBmcpackagelocale\fR, \fBmcforgetpackage\fR, \fBmcpackagenamespaceget\fR, \fBmcpackageconfig\fR, \fBmcset\fR and \fBmcmset\fR) may be called: +.PP +.SH 1) In class definition script +\fBmsgcat\fR command is called within a class definition script. +.CS +namespace eval ::N2 { + mcload $dir/msgs + oo::class create C1 {puts [mc Hi!]} +} +.CE +.PP +.SH 2) method defined in a class +\fBmsgcat\fR command is called from a method in an object and the method is defined in a class. +.CS +namespace eval ::N3Class { + mcload $dir/msgs + oo::class create C1 + oo::define C1 method m1 { + puts [mc Hi!] + } +} +.CE +.PP +.SH 3) method defined in a classless object +\fBmsgcat\fR command is called from a method of a classless object. +.CS +namespace eval ::N4 { + mcload $dir/msgs + oo::object create O1 + oo::objdefine O1 method m1 {} { + puts [mc Hi!] + } +} +.CE +.PP +.VE tip490 +.SH Examples Packages which display a GUI may update their widgets when the global locale changes. To register to a callback, use: .CS diff --git a/library/msgcat/msgcat.tcl b/library/msgcat/msgcat.tcl index 50a9064..100f425 100644 --- a/library/msgcat/msgcat.tcl +++ b/library/msgcat/msgcat.tcl @@ -4,7 +4,7 @@ # message catalog facility for Tcl programs. It should be # loaded with the command "package require msgcat". # -# Copyright (c) 2010-2015 by Harald Oehlmann. +# Copyright (c) 2010-2018 by Harald Oehlmann. # Copyright (c) 1998-2000 by Ajuba Solutions. # Copyright (c) 1998 by Mark Harrison. # @@ -1218,7 +1218,7 @@ proc msgcat::mcutil::ConvertLocale {value} { # - called from a classless oo object proc ::msgcat::PackageNamespaceGet {} { uplevel 2 { - # Check for no object + # Check self namespace to determine environment switch -exact -- [namespace which self] { {::oo::define::self} { # We are within a class definition -- cgit v0.12 From a275b8a5ea188f0633caab60b3ab709de4239f1f Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 13 Mar 2018 16:03:39 +0000 Subject: Rewrite the [string replace] compiler to take advantage of the richer set of encoded index values. --- generic/tclCompCmdsSZ.c | 241 +++++++++++++++++++++++++++++------------------- 1 file changed, 145 insertions(+), 96 deletions(-) diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index e84f382..c13376b 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -995,148 +995,197 @@ TclCompileStringReplaceCmd( * compiled. */ CompileEnv *envPtr) /* Holds the resulting instructions. */ { - Tcl_Token *tokenPtr, *valueTokenPtr, *replacementTokenPtr = NULL; + Tcl_Token *tokenPtr, *valueTokenPtr; DefineLineInformation; /* TIP #280 */ - int idx1, idx2; + int first, last; if (parsePtr->numWords < 4 || parsePtr->numWords > 5) { return TCL_ERROR; } + + /* Bytecode to compute/push string argument being replaced */ valueTokenPtr = TokenAfter(parsePtr->tokenPtr); - if (parsePtr->numWords == 5) { - tokenPtr = TokenAfter(valueTokenPtr); - tokenPtr = TokenAfter(tokenPtr); - replacementTokenPtr = TokenAfter(tokenPtr); - } - goto genericReplace; + CompileWord(envPtr, valueTokenPtr, interp, 1); + /* + * Check for first index known and useful at compile time. + */ tokenPtr = TokenAfter(valueTokenPtr); - if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_START, TCL_INDEX_AFTER, - &idx1) != TCL_OK) { + if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_AFTER, + &first) != TCL_OK) { goto genericReplace; } + /* - * Token parsed as an index value. Indices before the string are - * treated as index of start of string. + * Check for last index known and useful at compile time. */ - tokenPtr = TokenAfter(tokenPtr); - if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_END, - &idx2) != TCL_OK) { + if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_AFTER, + &last) != TCL_OK) { goto genericReplace; } - /* - * Token parsed as an index value. Indices after the string are - * treated as index of end of string. - */ -/* TODO...... */ - /* - * We handle these replacements specially: first character (where - * idx1=idx2=0) and last character (where idx1=idx2=TCL_INDEX_END). Anything - * else and the semantics get rather screwy. + /* + * [string replace] is an odd bird. For many arguments it is + * a conventional substring replacer. However it also goes out + * of its way to become a no-op for many cases where it would be + * replacing an empty substring. Precisely, it is a no-op when * - * TODO: These seem to be very narrow cases. They are not even - * covered by the test suite, and any programming that ends up - * here could have been coded by the programmer using [string range] - * and [string cat]. [*] Not clear at all to me that the bytecode - * generated here is worthwhile. + * (last < first) OR + * (last < 0) OR + * (end < first) * - * [*] Except for the empty string exceptions. UGGGGHHHH. + * For some compile-time values we can detect these cases, and + * compile direct to bytecode implementing the no-op. */ - if (idx1 == 0 && idx2 == 0) { - int notEq, end; + if ((last == TCL_INDEX_BEFORE) /* Know (last < 0) */ + || (first == TCL_INDEX_AFTER) /* Know (first > end) */ /* - * Just working with the first character. + * Tricky to determine when runtime (last < first) can be + * certainly known based on the encoded values. Consider the + * cases... + * + * (first <= TCL_INDEX_END) && + * (last == TCL_INDEX_AFTER) => cannot tell REJECT + * (last <= TCL_INDEX END) && (last < first) => ACCEPT + * else => cannot tell REJECT */ - - CompileWord(envPtr, valueTokenPtr, interp, 1); - if (replacementTokenPtr == NULL) { - /* Drop first */ - OP44( STR_RANGE_IMM, 1, TCL_INDEX_END); - return TCL_OK; - } - /* Replace first */ - CompileWord(envPtr, replacementTokenPtr, interp, 4); - + || ((first <= TCL_INDEX_END) && (last <= TCL_INDEX_END) + && (last < first)) /* Know (last < first) */ /* - * NOTE: The following tower of bullshit is present because - * [string replace] was boneheadedly defined not to replace - * empty strings, so we actually have to detect the empty - * string case and treat it differently. + * (first == TCL_INDEX_BEFORE) && + * (last == TCL_INDEX_AFTER) => (first < last) REJECT + * (last <= TCL_INDEX_END) => cannot tell REJECT + * else => (first < last) REJECT + * + * else [[first >= TCL_INDEX_START]] && + * (last == TCL_INDEX_AFTER) => cannot tell REJECT + * (last <= TCL_INDEX_END) => cannot tell REJECT + * else [[last >= TCL_INDEX START]] && (last < first) => ACCEPT */ - - OP4( OVER, 1); - PUSH( ""); - OP( STR_EQ); - JUMP1( JUMP_FALSE, notEq); - OP( POP); - JUMP1( JUMP, end); - FIXJUMP1(notEq); - TclAdjustStackDepth(1, envPtr); - OP4( REVERSE, 2); - OP44( STR_RANGE_IMM, 1, TCL_INDEX_END); - OP1( STR_CONCAT1, 2); - FIXJUMP1(end); + || ((first >= TCL_INDEX_START) && (last >= TCL_INDEX_START) + && (last < first))) { /* Know (last < first) */ + if (parsePtr->numWords == 5) { + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 4); + OP( POP); /* Pop newString */ + } + /* Original string argument now on TOS as result */ return TCL_OK; + } - } else if (idx1 == TCL_INDEX_END && idx2 == TCL_INDEX_END) { - int notEq, end; - - /* - * Just working with the last character. - */ + if (parsePtr->numWords == 5) { + /* + * When we have a string replacement, we have to take care about + * not replacing empty substrings that [string replace] promises + * not to replace + * + * The remaining index values might be suitable for conventional + * string replacement, but only if they cannot possibly meet the + * conditions described above at runtime. If there's a chance they + * might, we would have to emit bytecode to check and at that point + * we're paying more in bytecode execution time than would make + * things worthwhile. Trouble is we are very limited in + * how much we can detect that at compile time. After decoding, + * we need, first: + * + * (first <= end) + * + * The encoded indices (first <= TCL_INDEX END) and + * (first == TCL_INDEX_BEFORE) always meets this condition, but + * any other encoded first index has some list for which it fails. + * + * We also need, second: + * + * (last >= 0) + * + * The encoded indices (last >= TCL_INDEX_START) and + * (last == TCL_INDEX_AFTER) always meet this condition but any + * other encoded last index has some list for which it fails. + * + * Finally we need, third: + * + * (first <= last) + * + * Considered in combination with the constraints we already have, + * we see that we can proceed when (first == TCL_INDEX_BEFORE) + * or (last == TCL_INDEX_AFTER). These also permit simplification + * of the prefix|replace|suffix construction. The other constraints, + * though, interfere with getting a guarantee that first <= last. + */ - CompileWord(envPtr, valueTokenPtr, interp, 1); - if (replacementTokenPtr == NULL) { - /* Drop last */ - OP44( STR_RANGE_IMM, 0, TCL_INDEX_END-1); - return TCL_OK; + if ((first == TCL_INDEX_BEFORE) && (last >= TCL_INDEX_START)) { + /* empty prefix */ + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 4); + OP4( REVERSE, 2); + if (last == TCL_INDEX_AFTER) { + OP( POP); /* Pop original */ + } else { + OP44( STR_RANGE_IMM, last + 1, TCL_INDEX_END); + OP1( STR_CONCAT1, 2); } - /* Replace last */ - CompileWord(envPtr, replacementTokenPtr, interp, 4); - - /* More bullshit; see NOTE above. */ + return TCL_OK; + } - OP4( OVER, 1); - PUSH( ""); - OP( STR_EQ); - JUMP1( JUMP_FALSE, notEq); - OP( POP); - JUMP1( JUMP, end); - FIXJUMP1(notEq); - TclAdjustStackDepth(1, envPtr); - OP4( REVERSE, 2); - OP44( STR_RANGE_IMM, 0, TCL_INDEX_END-1); - OP4( REVERSE, 2); + if ((last == TCL_INDEX_AFTER) && (first <= TCL_INDEX_END)) { + OP44( STR_RANGE_IMM, 0, first-1); + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 4); OP1( STR_CONCAT1, 2); - FIXJUMP1(end); return TCL_OK; + } + + /* FLOW THROUGH TO genericReplace */ } else { - /* - * Need to process indices at runtime. This could be because the - * indices are not constants, or because we need to resolve them to - * absolute indices to work out if a replacement is going to happen. - * In any case, to runtime it is. + /* + * When we have no replacement string to worry about, we may + * have more luck, because the forbidden empty string replacements + * are harmless when they are replaced by another empty string. */ + if ((first == TCL_INDEX_BEFORE) || (first == TCL_INDEX_START)) { + /* empty prefix - build suffix only */ + + if ((last == TCL_INDEX_END) || (last == TCL_INDEX_AFTER)) { + /* empty suffix too => empty result */ + OP( POP); /* Pop original */ + PUSH ( ""); + return TCL_OK; + } + OP44( STR_RANGE_IMM, last + 1, TCL_INDEX_END); + return TCL_OK; + } else { + if ((last == TCL_INDEX_END) || (last == TCL_INDEX_AFTER)) { + /* empty suffix - build prefix only */ + OP44( STR_RANGE_IMM, 0, first-1); + return TCL_OK; + } + OP( DUP); + OP44( STR_RANGE_IMM, 0, first-1); + OP4( REVERSE, 2); + OP44( STR_RANGE_IMM, last + 1, TCL_INDEX_END); + OP1( STR_CONCAT1, 2); + return TCL_OK; + } + } + genericReplace: - CompileWord(envPtr, valueTokenPtr, interp, 1); tokenPtr = TokenAfter(valueTokenPtr); CompileWord(envPtr, tokenPtr, interp, 2); tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, 3); - if (replacementTokenPtr != NULL) { - CompileWord(envPtr, replacementTokenPtr, interp, 4); + if (parsePtr->numWords == 5) { + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 4); } else { PUSH( ""); } OP( STR_REPLACE); return TCL_OK; - } } int -- cgit v0.12 From bbae63cfa9695583ae13a24a1bf42d5931bbb116 Mon Sep 17 00:00:00 2001 From: oehhar Date: Tue, 13 Mar 2018 16:13:02 +0000 Subject: tip 499 msgcat custom preferences: documentation added --- doc/msgcat.n | 112 +++++++++++++++++++++++++++++++++++++++++++++-------------- 1 file changed, 85 insertions(+), 27 deletions(-) diff --git a/doc/msgcat.n b/doc/msgcat.n index fbea20f..9074725 100644 --- a/doc/msgcat.n +++ b/doc/msgcat.n @@ -29,7 +29,9 @@ msgcat \- Tcl message catalog .sp \fB::msgcat::mclocale \fR?\fInewLocale\fR? .sp -\fB::msgcat::mcpreferences\fR +.VS "TIP 499" +\fB::msgcat::mcpreferences\fR ?\fIlocale preference\fR? ... +.VE "TIP 499" .sp .VS "TIP 412" \fB::msgcat::mcloadedlocales subcommand\fR ?\fIlocale\fR? @@ -54,6 +56,10 @@ msgcat \- Tcl message catalog .sp \fB::msgcat::mcforgetpackage\fR .VE "TIP 412" +.sp +.VS "TIP 499" +\fB::msgcat::mcutil subcommand\fR ?\fIlocale\fR? +.VS "TIP 499" .BE .SH DESCRIPTION .PP @@ -145,7 +151,7 @@ The namespace of the caller is used if not explicitly specified. \fB::msgcat::mcpackagenamespaceget\fR . Return the package namespace of the caller. -This command handles all cases described in section \fBObject oriented programming\fR. +This command handles all cases described in section \fBOBJECT ORIENTED PROGRAMMING\fR. .PP .RS Example usage is a tooltip package, which saves the caller package namespace to update the translation each time the tooltip is shown: @@ -169,14 +175,22 @@ proc ::tooltip::show {widget messagenamespace message} { .TP \fB::msgcat::mclocale \fR?\fInewLocale\fR? . -This function sets the locale to \fInewLocale\fR. If \fInewLocale\fR -is omitted, the current locale is returned, otherwise the current locale -is set to \fInewLocale\fR. msgcat stores and compares the locale in a +If \fInewLocale\fR is omitted, the current locale is returned, otherwise the current locale +is set to \fInewLocale\fR. +.PP +.RS +If the new locale is set to \fInewLocale\fR, the corresponding preferences are calculated and set. +For example, if the current locale is en_US_funky, then \fB::msgcat::mcpreferences\fR returns \fB{en_us_funky en_us en {}}\fR. +.PP +The same result may be acheved by \fB::msgcat::mcpreferences\fR {*}[\fB::msgcat::mcutil getpreferences\fR \fInewLocale\fR]. +.PP +The current locale is always the first element of the list returned by \fBmcpreferences\fR. +.PP +msgcat stores and compares the locale in a case-insensitive manner, and returns locales in lowercase. The initial locale is determined by the locale specified in the user's environment. See \fBLOCALE SPECIFICATION\fR below for a description of the locale string format. -.RS .PP .VS "TIP 412" If the locale is set, the preference list of locales is evaluated. @@ -184,16 +198,26 @@ Locales in this list are loaded now, if not jet loaded. .VE "TIP 412" .RE .TP -\fB::msgcat::mcpreferences\fR +\fB::msgcat::mcpreferences\fR ?\fIlocale preference\fR? ... . -Returns an ordered list of the locales preferred by -the user, based on the user's language specification. -The list is ordered from most specific to least -preference. The list is derived from the current -locale set in msgcat by \fB::msgcat::mclocale\fR, and -cannot be set independently. For example, if the -current locale is en_US_funky, then \fB::msgcat::mcpreferences\fR -returns \fB{en_us_funky en_us en {}}\fR. +Without arguments, returns an ordered list of the locales preferred by +the user. +The list is ordered from most specific to least preference. +.PP +.VS "TIP 499" +.RS +A set of locale preferences may be given to set the list of locale preferences. +The current locale is also set, which is the first element of the locale preferences list. +.PP +Locale preferences are loaded now, if not jet loaded. +.PP +As an example, the user may prefer French or English text. This may be configured by: +.CS +::msgcat::mcpreferences fr en {} +.CE +.RE +.PP +.VS "TIP 499" .TP \fB::msgcat:mcloadedlocales subcommand\fR ?\fIlocale\fR? . @@ -284,6 +308,22 @@ Note that this routine is only called if the concerned package did not set a pac The calling package clears all its state within the \fBmsgcat\fR package including all settings and translations. .VE "TIP 412" .PP +.VS "TIP 499" +.TP +\fB::msgcat::mcutil getpreferences\fR \fIlocale\fR +. +Return the preferences list of the given locale as described in section \fBLOCALE SPECIFICATION\fR. +An example is the composition of a preference list for the bilingual region "Biel/Bienne" as a concatenation of swiss german and swiss french: +.CS +% concat [lrange [msgcat::mcutil getpreferences fr_CH] 0 end-1] [msgcat::mcutil getpreferences de_CH] +fr_ch fr de_ch de {} +.CE +.TP +\fB::msgcat::mcutil getsystemlocale\fR +. +The system locale is returned as described by the section \fBLOCALE SPECIFICATION\fR. +.VE "TIP 499" +.PP .SH "LOCALE SPECIFICATION" .PP The locale is specified to \fBmsgcat\fR by a locale string @@ -489,7 +529,7 @@ formatting substitution is done directly. # human-oriented versions by \fBmsgcat::mcset\fR .CE .VS "TIP 412" -.SH Package private locale +.SH "PACKAGE PRIVATE LOCALE" .PP A package using \fBmsgcat\fR may choose to use its own package private locale and its own set of loaded locales, independent to the global @@ -513,10 +553,22 @@ This command may cause the load of locales. . Return the package private locale or the global locale, if no package private locale is set. .TP -\fB::msgcat::mcpackagelocale preferences\fR +\fB::msgcat::mcpackagelocale preferences\fR ?\fIlocale preference\fR? ... . -Return the package private preferences or the global preferences, +With no parameters, return the package private preferences or the global preferences, if no package private locale is set. +The package locale state (set or not) is not changed (in contrast to the command \fB::msgcat::mcpackagelocale set\fR). +.PP +.RS +.VS "TIP 499" +If a set of locale preferences is given, it is set as package locale preference list. +The package locale is set to the first element of the preference list. +A package locale is activated, if it was not set so far. +.PP +Locale preferences are loaded now for the package, if not jet loaded. +.VE "TIP 499" +.RE +.PP .TP \fB::msgcat::mcpackagelocale loaded\fR . @@ -540,7 +592,7 @@ Returns true, if the given locale is loaded for the package. . Clear any loaded locales of the package not present in the package preferences. .PP -.SH Changing package options +.SH "CHANGING PACKAGE OPTIONS" .PP Each package using msgcat has a set of options within \fBmsgcat\fR. The package options are described in the next sectionPackage options. @@ -615,7 +667,7 @@ A generic unknown handler is used if set to the empty string. This consists in r See section \fBcallback invocation\fR below. The appended arguments are identical to \fB::msgcat::mcunknown\fR. .RE -.SH Callback invocation +.SH "Callback invocation" A package may decide to register one or multiple callbacks, as described above. .PP Callbacks are invoked, if: @@ -630,13 +682,15 @@ If a called routine fails with an error, the \fBbgerror\fR routine for the inter Only exception is the callback \fBunknowncmd\fR, where an error causes the invoking \fBmc\fR-command to fail with that error. .PP .VS tip490 -.SH Object oriented programming +.SH "OBJECT ORIENTED PROGRAMMING" \fBmsgcat\fR supports packages implemented by object oriented programming. Objects and classes should be defined within a package namespace. .PP There are 3 supported cases where package namespace sensitive commands of msgcat (\fBmc\fR, \fBmcexists\fR, \fBmcpackagelocale\fR, \fBmcforgetpackage\fR, \fBmcpackagenamespaceget\fR, \fBmcpackageconfig\fR, \fBmcset\fR and \fBmcmset\fR) may be called: .PP -.SH 1) In class definition script +.TP +\fB1) In class definition script\fR +. \fBmsgcat\fR command is called within a class definition script. .CS namespace eval ::N2 { @@ -645,7 +699,9 @@ namespace eval ::N2 { } .CE .PP -.SH 2) method defined in a class +.TP +\fB2) method defined in a class\fR +. \fBmsgcat\fR command is called from a method in an object and the method is defined in a class. .CS namespace eval ::N3Class { @@ -657,7 +713,9 @@ namespace eval ::N3Class { } .CE .PP -.SH 3) method defined in a classless object +.TP +\fB3) method defined in a classless object\fR +. \fBmsgcat\fR command is called from a method of a classless object. .CS namespace eval ::N4 { @@ -670,7 +728,7 @@ namespace eval ::N4 { .CE .PP .VE tip490 -.SH Examples +.SH EXAMPLES Packages which display a GUI may update their widgets when the global locale changes. To register to a callback, use: .CS @@ -736,9 +794,9 @@ proc ::tcl::clock::LocalizeFormat { locale format } { .PP The message catalog code was developed by Mark Harrison. .SH "SEE ALSO" -format(n), scan(n), namespace(n), package(n) +format(n), scan(n), namespace(n), package(n), oo::class(n), oo::object .SH KEYWORDS -internationalization, i18n, localization, l10n, message, text, translation +internationalization, i18n, localization, l10n, message, text, translation, class, object .\" Local Variables: .\" mode: nroff .\" End: -- cgit v0.12 From 9ac074bd097e9924cd88d9fa603e507e9380c2a7 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 13 Mar 2018 16:28:43 +0000 Subject: Fix bugs in msgcat that prevent clean test suite run. --- library/msgcat/msgcat.tcl | 2 +- tests/msgcat.test | 5 +++++ 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/library/msgcat/msgcat.tcl b/library/msgcat/msgcat.tcl index 100f425..598330d 100644 --- a/library/msgcat/msgcat.tcl +++ b/library/msgcat/msgcat.tcl @@ -1260,7 +1260,7 @@ proc msgcat::mcutil::getsystemlocale {} { # On Darwin, fallback to current CFLocale identifier if available. # if {[info exists ::tcl::mac::locale] && $::tcl::mac::locale ne ""} { - if {![catch { ConvertLocale $::tcl::mac::locale] } locale]} { + if {![catch { ConvertLocale $::tcl::mac::locale } locale]} { return $locale } } diff --git a/tests/msgcat.test b/tests/msgcat.test index 7ab9bcf..0d2f928 100644 --- a/tests/msgcat.test +++ b/tests/msgcat.test @@ -55,8 +55,13 @@ namespace eval ::msgcat::test { set result [string tolower [lindex $setVars 0]] if {[string length $result] == 0} { if {[info exists ::tcl::mac::locale]} { +if {[package vsatisfies [package provide msgcat] 1.7]} { + set result [string tolower \ + [msgcat::mcutil::ConvertLocale $::tcl::mac::locale]] +} else { set result [string tolower \ [msgcat::ConvertLocale $::tcl::mac::locale]] +} } else { if {([info sharedlibextension] eq ".dll") && ![catch {package require registry}]} { -- cgit v0.12