summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--generic/tclInt.h9
-rw-r--r--generic/tclProcess.c176
-rw-r--r--tests/process.test10
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}
generated by cgit v0.12 at 2025-12-24 15:46:49 (GMT)