Compare commits
10
Commits
| Author | SHA1 | Date | |
|---|---|---|---|
|
|
6969ac4525 | ||
|
|
f355f5c61c | ||
|
|
a2bc3177e6 | ||
|
|
378c33ecef | ||
|
|
f772a56967 | ||
|
|
797f545684 | ||
|
|
5add128816 | ||
|
|
f1af859b9b | ||
|
|
c22f8db6b2 | ||
|
|
e6ce513bf2 |
+33
-54
@@ -8,7 +8,7 @@
|
||||
.so man.macros
|
||||
.BS
|
||||
.SH NAME
|
||||
Tcl_IsSafe, Tcl_MakeSafe, Tcl_CreateChild, Tcl_CreateSlave, Tcl_GetChild, Tcl_GetSlave, Tcl_GetParent, Tcl_GetMaster, Tcl_GetInterpPath, Tcl_CreateAlias, Tcl_CreateAliasObj, Tcl_GetAlias, Tcl_GetAliasObj, Tcl_ExposeCommand, Tcl_HideCommand \- manage multiple Tcl interpreters, aliases and hidden commands
|
||||
Tcl_IsSafe, Tcl_MakeSafe, Tcl_CreateChild, Tcl_GetChild, Tcl_GetParent, Tcl_GetInterpPath, Tcl_CreateAlias, Tcl_CreateAliasObj, Tcl_GetAlias, Tcl_GetAliasObj, Tcl_ExposeCommand, Tcl_HideCommand \- manage multiple Tcl interpreters, aliases and hidden commands
|
||||
.SH SYNOPSIS
|
||||
.nf
|
||||
\fB#include <tcl.h>\fR
|
||||
@@ -19,47 +19,38 @@ int
|
||||
int
|
||||
\fBTcl_MakeSafe\fR(\fIinterp\fR)
|
||||
.sp
|
||||
.VS "TIP 581"
|
||||
Tcl_Interp *
|
||||
\fBTcl_CreateChild\fR(\fIinterp, name, isSafe\fR)
|
||||
.VE "TIP 581"
|
||||
.sp
|
||||
Tcl_Interp *
|
||||
\fBTcl_CreateSlave\fR(\fIinterp, name, isSafe\fR)
|
||||
.sp
|
||||
.VS "TIP 581"
|
||||
Tcl_Interp *
|
||||
\fBTcl_GetChild\fR(\fIinterp, name\fR)
|
||||
.VE "TIP 581"
|
||||
.sp
|
||||
Tcl_Interp *
|
||||
\fBTcl_GetSlave\fR(\fIinterp, name\fR)
|
||||
\fBTcl_GetChild\fR(\fIinterp, name\fR)
|
||||
.sp
|
||||
.VS "TIP 581"
|
||||
Tcl_Interp *
|
||||
\fBTcl_GetParent\fR(\fIinterp\fR)
|
||||
.VE "TIP 581"
|
||||
.sp
|
||||
Tcl_Interp *
|
||||
\fBTcl_GetMaster\fR(\fIinterp\fR)
|
||||
\fBTcl_GetParent\fR(\fIinterp\fR)
|
||||
.sp
|
||||
int
|
||||
\fBTcl_GetInterpPath\fR(\fIinterp, slaveInterp\fR)
|
||||
\fBTcl_GetInterpPath\fR(\fIinterp, childInterp\fR)
|
||||
.sp
|
||||
int
|
||||
\fBTcl_CreateAlias\fR(\fIslaveInterp, slaveCmd, targetInterp, targetCmd,
|
||||
\fBTcl_CreateAlias\fR(\fIchildInterp, childCmd, targetInterp, targetCmd,
|
||||
argc, argv\fR)
|
||||
.sp
|
||||
int
|
||||
\fBTcl_CreateAliasObj\fR(\fIslaveInterp, slaveCmd, targetInterp, targetCmd,
|
||||
\fBTcl_CreateAliasObj\fR(\fIchildInterp, childCmd, targetInterp, targetCmd,
|
||||
objc, objv\fR)
|
||||
.sp
|
||||
int
|
||||
\fBTcl_GetAlias\fR(\fIinterp, slaveCmd, targetInterpPtr, targetCmdPtr,
|
||||
\fBTcl_GetAlias\fR(\fIinterp, childCmd, targetInterpPtr, targetCmdPtr,
|
||||
argcPtr, argvPtr\fR)
|
||||
.sp
|
||||
int
|
||||
\fBTcl_GetAliasObj\fR(\fIinterp, slaveCmd, targetInterpPtr, targetCmdPtr,
|
||||
\fBTcl_GetAliasObj\fR(\fIinterp, childCmd, targetInterpPtr, targetCmdPtr,
|
||||
objcPtr, objvPtr\fR)
|
||||
.sp
|
||||
int
|
||||
@@ -72,16 +63,16 @@ int
|
||||
.AP Tcl_Interp *interp in
|
||||
Interpreter in which to execute the specified command.
|
||||
.AP "const char" *name in
|
||||
Name of slave interpreter to create or manipulate.
|
||||
Name of child interpreter to create or manipulate.
|
||||
.AP int isSafe in
|
||||
If non-zero, a
|
||||
.QW safe
|
||||
slave that is suitable for running untrusted code
|
||||
is created, otherwise a trusted slave is created.
|
||||
.AP Tcl_Interp *slaveInterp in
|
||||
child that is suitable for running untrusted code
|
||||
is created, otherwise a trusted child is created.
|
||||
.AP Tcl_Interp *childInterp in
|
||||
Interpreter to use for creating the source command for an alias (see
|
||||
below).
|
||||
.AP "const char" *slaveCmd in
|
||||
.AP "const char" *childCmd in
|
||||
Name of source command for alias.
|
||||
.AP Tcl_Interp *targetInterp in
|
||||
Interpreter that contains the target command for an alias.
|
||||
@@ -136,21 +127,17 @@ interpreter. The return value for those procedures that return an \fBint\fR
|
||||
is either \fBTCL_OK\fR or \fBTCL_ERROR\fR. If \fBTCL_ERROR\fR is returned
|
||||
then the interpreter's result contains an error message.
|
||||
.PP
|
||||
\fBTcl_CreateSlave\fR creates a new interpreter as a slave of \fIinterp\fR.
|
||||
It also creates a slave command named \fIslaveName\fR in \fIinterp\fR which
|
||||
allows \fIinterp\fR to manipulate the new slave.
|
||||
If \fIisSafe\fR is zero, the command creates a trusted slave in which Tcl
|
||||
\fBTcl_CreateChild\fR creates a new interpreter as a child of \fIinterp\fR.
|
||||
It also creates a child command named \fIname\fR in \fIinterp\fR which
|
||||
allows \fIinterp\fR to manipulate the new child.
|
||||
If \fIisSafe\fR is zero, the command creates a trusted child in which Tcl
|
||||
code has access to all the Tcl commands.
|
||||
If it is \fB1\fR, the command creates a
|
||||
.QW safe
|
||||
slave in which Tcl code has access only to set of Tcl commands defined as
|
||||
child in which Tcl code has access only to set of Tcl commands defined as
|
||||
.QW "Safe Tcl" ;
|
||||
see the manual entry for the Tcl \fBinterp\fR command for details.
|
||||
If the creation of the new slave interpreter failed, \fBNULL\fR is returned.
|
||||
.PP
|
||||
.VS "TIP 581"
|
||||
\fBTcl_CreateChild\fR is a synonym for \fBTcl_CreateSlave\fR.
|
||||
.VE "TIP 581"
|
||||
If the creation of the new child interpreter failed, \fBNULL\fR is returned.
|
||||
.PP
|
||||
\fBTcl_IsSafe\fR returns \fB1\fR if \fIinterp\fR is
|
||||
.QW safe
|
||||
@@ -166,42 +153,34 @@ from \fIinterp\fR. However, it cannot know what parts of an extension
|
||||
or application are safe and does not make any attempt to remove those
|
||||
parts, so safety is not guaranteed after calling \fBTcl_MakeSafe\fR.
|
||||
Callers will want to take care with their use of \fBTcl_MakeSafe\fR
|
||||
to avoid false claims of safety. For many situations, \fBTcl_CreateSlave\fR
|
||||
to avoid false claims of safety. For many situations, \fBTcl_CreateChild\fR
|
||||
may be a better choice, since it creates interpreters in a known-safe state.
|
||||
.PP
|
||||
\fBTcl_GetSlave\fR returns a pointer to a slave interpreter of
|
||||
\fIinterp\fR. The slave interpreter is identified by \fIslaveName\fR.
|
||||
If no such slave interpreter exists, \fBNULL\fR is returned.
|
||||
\fBTcl_GetChild\fR returns a pointer to a child interpreter of
|
||||
\fIinterp\fR. The child interpreter is identified by \fIname\fR.
|
||||
If no such child interpreter exists, \fBNULL\fR is returned.
|
||||
.PP
|
||||
.VS "TIP 581"
|
||||
\fBTcl_GetChild\fR is a synonym for \fBTcl_GetSlave\fR.
|
||||
.VE "TIP 581"
|
||||
.PP
|
||||
\fBTcl_GetMaster\fR returns a pointer to the master interpreter of
|
||||
\fIinterp\fR. If \fIinterp\fR has no master (it is a
|
||||
\fBTcl_GetParent\fR returns a pointer to the parent interpreter of
|
||||
\fIinterp\fR. If \fIinterp\fR has no parent (it is a
|
||||
top-level interpreter) then \fBNULL\fR is returned.
|
||||
.PP
|
||||
.VS "TIP 581"
|
||||
\fBTcl_GetParent\fR is a synonym for \fBTcl_GetMaster\fR.
|
||||
.VE "TIP 581"
|
||||
.PP
|
||||
\fBTcl_GetInterpPath\fR stores in the result of \fIinterp\fR
|
||||
the relative path between \fIinterp\fR and \fIslaveInterp\fR;
|
||||
\fIslaveInterp\fR must be a slave of \fIinterp\fR. If the computation
|
||||
the relative path between \fIinterp\fR and \fIchildInterp\fR;
|
||||
\fIchildInterp\fR must be a child of \fIinterp\fR. If the computation
|
||||
of the relative path succeeds, \fBTCL_OK\fR is returned, else
|
||||
\fBTCL_ERROR\fR is returned and an error message is stored as the
|
||||
result of \fIinterp\fR.
|
||||
.PP
|
||||
\fBTcl_CreateAlias\fR creates a command named \fIslaveCmd\fR in
|
||||
\fIslaveInterp\fR that when invoked, will cause the command \fItargetCmd\fR
|
||||
\fBTcl_CreateAlias\fR creates a command named \fIchildCmd\fR in
|
||||
\fIchildInterp\fR that when invoked, will cause the command \fItargetCmd\fR
|
||||
to be invoked in \fItargetInterp\fR. The arguments specified by the strings
|
||||
contained in \fIargv\fR are always prepended to any arguments supplied in the
|
||||
invocation of \fIslaveCmd\fR and passed to \fItargetCmd\fR.
|
||||
invocation of \fIchildCmd\fR and passed to \fItargetCmd\fR.
|
||||
This operation returns \fBTCL_OK\fR if it succeeds, or \fBTCL_ERROR\fR if
|
||||
it fails; in that case, an error message is left in the value result
|
||||
of \fIslaveInterp\fR.
|
||||
of \fIchildInterp\fR.
|
||||
Note that there are no restrictions on the ancestry relationship (as
|
||||
created by \fBTcl_CreateSlave\fR) between \fIslaveInterp\fR and
|
||||
created by \fBTcl_CreateChild\fR) between \fIchildInterp\fR and
|
||||
\fItargetInterp\fR. Any two interpreters can be used, without any
|
||||
restrictions on how they are related.
|
||||
.PP
|
||||
@@ -260,4 +239,4 @@ interp
|
||||
|
||||
.SH KEYWORDS
|
||||
alias, command, exposed commands, hidden commands, interpreter, invoke,
|
||||
master, slave
|
||||
parent, child
|
||||
|
||||
+2
-2
@@ -1350,11 +1350,11 @@ is considered to be owned by the filesystem (not by Tcl's core), but
|
||||
should be given a reference count for Tcl. Tcl will use the contents of the
|
||||
list and then decrement that reference count. This allows filesystems to
|
||||
choose whether they actually want to retain a
|
||||
.QW "master list"
|
||||
.QW "main list"
|
||||
of volumes
|
||||
or not (if not, they generate the list on the fly and pass it to Tcl
|
||||
with a reference count of 1 and then forget about the list, if yes, then
|
||||
they simply increment the reference count of their master list and pass it
|
||||
they simply increment the reference count of their main list and pass it
|
||||
to Tcl which will copy the contents and then decrement the count back
|
||||
to where it was).
|
||||
.PP
|
||||
|
||||
+1
-1
@@ -116,7 +116,7 @@ execution of the callbacks is unspecified) execution in the limited
|
||||
interpreter is stopped by raising an error and setting a flag that
|
||||
prevents the \fBcatch\fR command in that interpreter from trapping
|
||||
that error. It is up to the context that started execution in that
|
||||
interpreter (typically a master interpreter) to handle the error.
|
||||
interpreter (typically a parent interpreter) to handle the error.
|
||||
.SH "LIMIT CHECKING API"
|
||||
.PP
|
||||
To check the resource limits for an interpreter, call
|
||||
|
||||
+6
-6
@@ -79,7 +79,7 @@ against the standard Tcl library. Extensions (stub-enabled or
|
||||
not) are not intended to call \fBTcl_Main\fR.
|
||||
.PP
|
||||
\fBTcl_Main\fR is not thread-safe. It should only be called by
|
||||
a single master thread of a multi-threaded application. This
|
||||
a single main thread of a multi-threaded application. This
|
||||
restriction is not a problem with normal use described above.
|
||||
.PP
|
||||
\fBTcl_Main\fR and therefore all applications based upon it, like
|
||||
@@ -112,7 +112,7 @@ The file name and encoding values managed by the routines
|
||||
\fBTcl_SetStartupScript\fR and \fBTcl_GetStartupScript\fR
|
||||
are stored per-thread. Although the storage and retrieval
|
||||
functions of these routines work in any thread, only those
|
||||
calls in the same master thread as \fBTcl_Main\fR can have
|
||||
calls in the same main thread as \fBTcl_Main\fR can have
|
||||
any influence on it.
|
||||
.PP
|
||||
The caller of \fBTcl_Main\fR may call \fBTcl_SetStartupScript\fR
|
||||
@@ -126,7 +126,7 @@ a \fIstartup script\fR, and \fIname\fR is taken to be the name
|
||||
of the encoding of the contents of that file. \fBTcl_Main\fR
|
||||
then calls \fBTcl_SetStartupScript\fR with these values.
|
||||
.PP
|
||||
\fBTcl_Main\fR then defines in its master interpreter
|
||||
\fBTcl_Main\fR then defines in its main interpreter
|
||||
the Tcl variables \fIargc\fR, \fIargv\fR, \fIargv0\fR, and
|
||||
\fItcl_interactive\fR, as described in the documentation for \fBtclsh\fR.
|
||||
.PP
|
||||
@@ -154,9 +154,9 @@ When the \fIappInitProc\fR is finished, \fBTcl_Main\fR calls
|
||||
been requested, if any. If a startup script has been provided,
|
||||
\fBTcl_Main\fR attempts to evaluate it. Otherwise, interactive
|
||||
mode begins with examination of the variable \fItcl_rcFileName\fR
|
||||
in the master interpreter. If that variable exists and holds the
|
||||
in the main interpreter. If that variable exists and holds the
|
||||
name of a readable file, the contents of that file are evaluated
|
||||
in the master interpreter. Then interactive operations begin,
|
||||
in the main interpreter. Then interactive operations begin,
|
||||
with prompts and command evaluation results written to the standard
|
||||
output channel, and commands read from the standard input channel
|
||||
and then evaluated. The prompts written to the standard output
|
||||
@@ -164,7 +164,7 @@ channel may be customized by defining the Tcl variables \fItcl_prompt1\fR
|
||||
and \fItcl_prompt2\fR as described in the documentation for \fBtclsh\fR.
|
||||
The prompts and command evaluation results are written to the standard
|
||||
output channel only if the Tcl variable \fItcl_interactive\fR in the
|
||||
master interpreter holds a non-zero integer value.
|
||||
main interpreter holds a non-zero integer value.
|
||||
.PP
|
||||
\fBTcl_SetMainLoop\fR allows setting an event loop procedure to be run.
|
||||
This allows, for example, Tk to be dynamically loaded and set its event
|
||||
|
||||
+121
-127
@@ -19,18 +19,18 @@ interp \- Create and manipulate Tcl interpreters
|
||||
.PP
|
||||
This command makes it possible to create one or more new Tcl
|
||||
interpreters that co-exist with the creating interpreter in the
|
||||
same application. The creating interpreter is called the \fImaster\fR
|
||||
and the new interpreter is called a \fIslave\fR.
|
||||
A master can create any number of slaves, and each slave can
|
||||
itself create additional slaves for which it is master, resulting
|
||||
same application. The creating interpreter is called the \fIparent\fR
|
||||
and the new interpreter is called a \fIchild\fR.
|
||||
A parent can create any number of children, and each child can
|
||||
itself create additional children for which it is parent, resulting
|
||||
in a hierarchy of interpreters.
|
||||
.PP
|
||||
Each interpreter is independent from the others: it has its own name
|
||||
space for commands, procedures, and global variables.
|
||||
A master interpreter may create connections between its slaves and
|
||||
A parent interpreter may create connections between its children and
|
||||
itself using a mechanism called an \fIalias\fR. An \fIalias\fR is
|
||||
a command in a slave interpreter which, when invoked, causes a
|
||||
command to be invoked in its master interpreter or in another slave
|
||||
a command in a child interpreter which, when invoked, causes a
|
||||
command to be invoked in its parent interpreter or in another child
|
||||
interpreter. The only other connections between interpreters are
|
||||
through environment variables (the \fBenv\fR variable), which are
|
||||
normally shared among all interpreters in the application,
|
||||
@@ -41,7 +41,7 @@ share files and to transfer references to open files from one interpreter
|
||||
to another.
|
||||
.PP
|
||||
The \fBinterp\fR command also provides support for \fIsafe\fR
|
||||
interpreters. A safe interpreter is a slave whose functions have
|
||||
interpreters. A safe interpreter is a child whose functions have
|
||||
been greatly restricted, so that it is safe to execute untrusted
|
||||
scripts without fear of them damaging other interpreters or the
|
||||
application's environment. For example, all IO channel creation
|
||||
@@ -54,18 +54,18 @@ instead, it is \fIhidden\fR, so that only trusted interpreters can obtain
|
||||
access to it. For a detailed explanation of hidden commands, see
|
||||
\fBHIDDEN COMMANDS\fR, below.
|
||||
The alias mechanism can be used for protected communication (analogous to a
|
||||
kernel call) between a slave interpreter and its master.
|
||||
kernel call) between a child interpreter and its parent.
|
||||
See \fBALIAS INVOCATION\fR, below, for more details
|
||||
on how the alias mechanism works.
|
||||
.PP
|
||||
A qualified interpreter name is a proper Tcl lists containing a subset of its
|
||||
ancestors in the interpreter hierarchy, terminated by the string naming the
|
||||
interpreter in its immediate master. Interpreter names are relative to the
|
||||
interpreter in its immediate parent. Interpreter names are relative to the
|
||||
interpreter in which they are used. For example, if
|
||||
.QW \fBa\fR
|
||||
is a slave of the current interpreter and it has a slave
|
||||
is a child of the current interpreter and it has a child
|
||||
.QW \fBa1\fR ,
|
||||
which in turn has a slave
|
||||
which in turn has a child
|
||||
.QW \fBa11\fR ,
|
||||
the qualified name of
|
||||
.QW \fBa11\fR
|
||||
@@ -77,14 +77,14 @@ is the list
|
||||
The \fBinterp\fR command, described below, accepts qualified interpreter
|
||||
names as arguments; the interpreter in which the command is being evaluated
|
||||
can always be referred to as \fB{}\fR (the empty list or string). Note that
|
||||
it is impossible to refer to a master (ancestor) interpreter by name in a
|
||||
slave interpreter except through aliases. Also, there is no global name by
|
||||
it is impossible to refer to a parent (ancestor) interpreter by name in a
|
||||
child interpreter except through aliases. Also, there is no global name by
|
||||
which one can refer to the first interpreter created in an application.
|
||||
Both restrictions are motivated by safety concerns.
|
||||
.SH "THE INTERP COMMAND"
|
||||
.PP
|
||||
The \fBinterp\fR command is used to create, delete, and manipulate
|
||||
slave interpreters, and to share or transfer
|
||||
child interpreters, and to share or transfer
|
||||
channels between interpreters. It can have any of several forms, depending
|
||||
on the \fIsubcommand\fR argument:
|
||||
.TP
|
||||
@@ -94,11 +94,11 @@ Returns a Tcl list whose elements are the \fItargetCmd\fR and
|
||||
\fIarg\fRs associated with the alias represented by \fIsrcToken\fR
|
||||
(this is the value returned when the alias was
|
||||
created; it is possible that the name of the source command in the
|
||||
slave is different from \fIsrcToken\fR).
|
||||
child is different from \fIsrcToken\fR).
|
||||
.TP
|
||||
\fBinterp\fR \fBalias\fR \fIsrcPath\fR \fIsrcToken\fR \fB{}\fR
|
||||
.
|
||||
Deletes the alias for \fIsrcToken\fR in the slave interpreter identified by
|
||||
Deletes the alias for \fIsrcToken\fR in the child interpreter identified by
|
||||
\fIsrcPath\fR.
|
||||
\fIsrcToken\fR refers to the value returned when the alias
|
||||
was created; if the source command has been renamed, the renamed
|
||||
@@ -106,9 +106,9 @@ command will be deleted.
|
||||
.TP
|
||||
\fBinterp\fR \fBalias\fR \fIsrcPath\fR \fIsrcCmd\fR \fItargetPath\fR \fItargetCmd \fR?\fIarg arg ...\fR?
|
||||
.
|
||||
This command creates an alias between one slave and another (see the
|
||||
\fBalias\fR slave command below for creating aliases between a slave
|
||||
and its master). In this command, either of the slave interpreters
|
||||
This command creates an alias between one child and another (see the
|
||||
\fBalias\fR child command below for creating aliases between a child
|
||||
and its parent). In this command, either of the child interpreters
|
||||
may be anywhere in the hierarchy of interpreters under the interpreter
|
||||
invoking the command.
|
||||
\fISrcPath\fR and \fIsrcCmd\fR identify the source of the alias.
|
||||
@@ -117,9 +117,9 @@ interpreter. For example,
|
||||
.QW "\fBa b\fR"
|
||||
identifies an interpreter
|
||||
.QW \fBb\fR ,
|
||||
which is a slave of interpreter
|
||||
which is a child of interpreter
|
||||
.QW \fBa\fR ,
|
||||
which is a slave of the invoking interpreter. An empty list specifies
|
||||
which is a child of the invoking interpreter. An empty list specifies
|
||||
the interpreter invoking the command. \fIsrcCmd\fR gives the name of
|
||||
a new command, which will be created in the source interpreter.
|
||||
\fITargetPath\fR and \fItargetCmd\fR specify a target interpreter
|
||||
@@ -171,33 +171,33 @@ used.
|
||||
.TP
|
||||
\fBinterp\fR \fBcreate \fR?\fB\-safe\fR? ?\fB\-\|\-\fR? ?\fIpath\fR?
|
||||
.
|
||||
Creates a slave interpreter identified by \fIpath\fR and a new command,
|
||||
called a \fIslave command\fR. The name of the slave command is the last
|
||||
component of \fIpath\fR. The new slave interpreter and the slave command
|
||||
Creates a child interpreter identified by \fIpath\fR and a new command,
|
||||
called a \fIchild command\fR. The name of the child command is the last
|
||||
component of \fIpath\fR. The new child interpreter and the child command
|
||||
are created in the interpreter identified by the path obtained by removing
|
||||
the last component from \fIpath\fR. For example, if \fIpath\fR is \fBa b
|
||||
c\fR then a new slave interpreter and slave command named \fBc\fR are
|
||||
c\fR then a new child interpreter and child command named \fBc\fR are
|
||||
created in the interpreter identified by the path \fBa b\fR.
|
||||
The slave command may be used to manipulate the new interpreter as
|
||||
The child command may be used to manipulate the new interpreter as
|
||||
described below. If \fIpath\fR is omitted, Tcl creates a unique name of the
|
||||
form \fBinterp\fIx\fR, where \fIx\fR is an integer, and uses it for the
|
||||
interpreter and the slave command. If the \fB\-safe\fR switch is specified
|
||||
(or if the master interpreter is a safe interpreter), the new slave
|
||||
interpreter and the child command. If the \fB\-safe\fR switch is specified
|
||||
(or if the parent interpreter is a safe interpreter), the new child
|
||||
interpreter will be created as a safe interpreter with limited
|
||||
functionality; otherwise the slave will include the full set of Tcl
|
||||
functionality; otherwise the child will include the full set of Tcl
|
||||
built-in commands and variables. The \fB\-\|\-\fR switch can be used to
|
||||
mark the end of switches; it may be needed if \fIpath\fR is an unusual
|
||||
value such as \fB\-safe\fR. The result of the command is the name of the
|
||||
new interpreter. The name of a slave interpreter must be unique among all
|
||||
the slaves for its master; an error occurs if a slave interpreter by the
|
||||
given name already exists in this master.
|
||||
The initial recursion limit of the slave interpreter is set to the
|
||||
new interpreter. The name of a child interpreter must be unique among all
|
||||
the children for its parent; an error occurs if a child interpreter by the
|
||||
given name already exists in this parent.
|
||||
The initial recursion limit of the child interpreter is set to the
|
||||
current recursion limit of its parent interpreter.
|
||||
.TP
|
||||
\fBinterp\fR \fBdebug \fIpath\fR ?\fB\-frame\fR ?\fIbool\fR??
|
||||
.
|
||||
Controls whether frame-level stack information is captured in the
|
||||
slave interpreter identified by \fIpath\fR. If no arguments are
|
||||
child interpreter identified by \fIpath\fR. If no arguments are
|
||||
given, option and current setting are returned. If \fB\-frame\fR
|
||||
is given, the debug setting is set to the given boolean if provided
|
||||
and the current setting is returned.
|
||||
@@ -239,8 +239,8 @@ consistency of the underlying interpreter's state.
|
||||
\fBinterp\fR \fBdelete \fR?\fIpath ...?\fR
|
||||
.
|
||||
Deletes zero or more interpreters given by the optional \fIpath\fR
|
||||
arguments, and for each interpreter, it also deletes its slaves. The
|
||||
command also deletes the slave command for each interpreter deleted.
|
||||
arguments, and for each interpreter, it also deletes its children. The
|
||||
command also deletes the child command for each interpreter deleted.
|
||||
For each \fIpath\fR argument, if no interpreter by that name
|
||||
exists, the command raises an error.
|
||||
.TP
|
||||
@@ -248,20 +248,20 @@ exists, the command raises an error.
|
||||
.
|
||||
This command concatenates all of the \fIarg\fR arguments in the same
|
||||
fashion as the \fBconcat\fR command, then evaluates the resulting string as
|
||||
a Tcl script in the slave interpreter identified by \fIpath\fR. The result
|
||||
a Tcl script in the child interpreter identified by \fIpath\fR. The result
|
||||
of this evaluation (including all \fBreturn\fR options,
|
||||
such as \fB\-errorinfo\fR and \fB\-errorcode\fR information, if an
|
||||
error occurs) is returned to the invoking interpreter.
|
||||
Note that the script will be executed in the current context stack frame of the
|
||||
\fIpath\fR interpreter; this is so that the implementations (in a master
|
||||
interpreter) of aliases in a slave interpreter can execute scripts in
|
||||
the slave that find out information about the slave's current state
|
||||
\fIpath\fR interpreter; this is so that the implementations (in a parent
|
||||
interpreter) of aliases in a child interpreter can execute scripts in
|
||||
the child that find out information about the child's current state
|
||||
and stack frame.
|
||||
.TP
|
||||
\fBinterp exists \fIpath\fR
|
||||
.
|
||||
Returns \fB1\fR if a slave interpreter by the specified \fIpath\fR
|
||||
exists in this master, \fB0\fR otherwise. If \fIpath\fR is omitted, the
|
||||
Returns \fB1\fR if a child interpreter by the specified \fIpath\fR
|
||||
exists in this parent, \fB0\fR otherwise. If \fIpath\fR is omitted, the
|
||||
invoking interpreter is used.
|
||||
.TP
|
||||
\fBinterp expose \fIpath\fR \fIhiddenName\fR ?\fIexposedCmdName\fR?
|
||||
@@ -287,7 +287,7 @@ Currently both \fIexposedCmdName\fR and \fIhiddenCmdName\fR can
|
||||
not contain namespace qualifiers, or an error is raised.
|
||||
Commands to be hidden by \fBinterp hide\fR are looked up in the global
|
||||
namespace even if the current namespace is not the global one. This
|
||||
prevents slaves from fooling a master interpreter into hiding the wrong
|
||||
prevents children from fooling a parent interpreter into hiding the wrong
|
||||
command, by making the current namespace be different from the global one.
|
||||
Hidden commands are explained in more detail in \fBHIDDEN COMMANDS\fR, below.
|
||||
.TP
|
||||
@@ -371,17 +371,11 @@ Both interpreters must close it to close the underlying IO channel; IO
|
||||
channels accessible in an interpreter are automatically closed when an
|
||||
interpreter is destroyed.
|
||||
.TP
|
||||
\fBinterp\fR \fBslaves\fR ?\fIpath\fR?
|
||||
.
|
||||
Returns a Tcl list of the names of all the slave interpreters associated
|
||||
with the interpreter identified by \fIpath\fR. If \fIpath\fR is omitted,
|
||||
the invoking interpreter is used.
|
||||
.TP
|
||||
.VS "TIP 581"
|
||||
\fBinterp\fR \fBchildren\fR ?\fIpath\fR?
|
||||
.
|
||||
Synonym for . \fBinterp\fR \fBslaves\fR ?\fIpath\fR?
|
||||
.VE "TIP 581"
|
||||
Returns a Tcl list of the names of all the child interpreters associated
|
||||
with the interpreter identified by \fIpath\fR. If \fIpath\fR is omitted,
|
||||
the invoking interpreter is used.
|
||||
.TP
|
||||
\fBinterp\fR \fBtarget\fR \fIpath alias\fR
|
||||
.
|
||||
@@ -399,48 +393,48 @@ The target command does not have to be defined at the time of this invocation.
|
||||
Causes the IO channel identified by \fIchannelId\fR to become available in
|
||||
the interpreter identified by \fIdestPath\fR and unavailable in the
|
||||
interpreter identified by \fIsrcPath\fR.
|
||||
.SH "SLAVE COMMAND"
|
||||
.SH "CHILD COMMAND"
|
||||
.PP
|
||||
For each slave interpreter created with the \fBinterp\fR command, a
|
||||
new Tcl command is created in the master interpreter with the same
|
||||
For each child interpreter created with the \fBinterp\fR command, a
|
||||
new Tcl command is created in the parent interpreter with the same
|
||||
name as the new interpreter. This command may be used to invoke
|
||||
various operations on the interpreter. It has the following
|
||||
general form:
|
||||
.PP
|
||||
.CS
|
||||
\fIslave command \fR?\fIarg arg ...\fR?
|
||||
\fIchild command \fR?\fIarg arg ...\fR?
|
||||
.CE
|
||||
.PP
|
||||
\fISlave\fR is the name of the interpreter, and \fIcommand\fR
|
||||
\fIChild\fR is the name of the interpreter, and \fIcommand\fR
|
||||
and the \fIarg\fRs determine the exact behavior of the command.
|
||||
The valid forms of this command are:
|
||||
.TP
|
||||
\fIslave \fBaliases\fR
|
||||
\fIchild \fBaliases\fR
|
||||
.
|
||||
Returns a Tcl list whose elements are the tokens of all the
|
||||
aliases in \fIslave\fR. The tokens correspond to the values returned when
|
||||
aliases in \fIchild\fR. The tokens correspond to the values returned when
|
||||
the aliases were created (which may not be the same
|
||||
as the current names of the commands).
|
||||
.TP
|
||||
\fIslave \fBalias \fIsrcToken\fR
|
||||
\fIchild \fBalias \fIsrcToken\fR
|
||||
.
|
||||
Returns a Tcl list whose elements are the \fItargetCmd\fR and
|
||||
\fIarg\fRs associated with the alias represented by \fIsrcToken\fR
|
||||
(this is the value returned when the alias was
|
||||
created; it is possible that the actual source command in the
|
||||
slave is different from \fIsrcToken\fR).
|
||||
child is different from \fIsrcToken\fR).
|
||||
.TP
|
||||
\fIslave \fBalias \fIsrcToken \fB{}\fR
|
||||
\fIchild \fBalias \fIsrcToken \fB{}\fR
|
||||
.
|
||||
Deletes the alias for \fIsrcToken\fR in the slave interpreter.
|
||||
Deletes the alias for \fIsrcToken\fR in the child interpreter.
|
||||
\fIsrcToken\fR refers to the value returned when the alias
|
||||
was created; if the source command has been renamed, the renamed
|
||||
command will be deleted.
|
||||
.TP
|
||||
\fIslave \fBalias \fIsrcCmd targetCmd \fR?\fIarg ..\fR?
|
||||
\fIchild \fBalias \fIsrcCmd targetCmd \fR?\fIarg ..\fR?
|
||||
.
|
||||
Creates an alias such that whenever \fIsrcCmd\fR is invoked
|
||||
in \fIslave\fR, \fItargetCmd\fR is invoked in the master.
|
||||
in \fIchild\fR, \fItargetCmd\fR is invoked in the parent.
|
||||
The \fIarg\fR arguments will be passed to \fItargetCmd\fR as additional
|
||||
arguments, prepended before any arguments passed in the invocation of
|
||||
\fIsrcCmd\fR.
|
||||
@@ -449,69 +443,69 @@ The command returns a token that uniquely identifies the command created
|
||||
\fIsrcCmd\fR, even if the command is renamed afterwards. The token may but
|
||||
does not have to be equal to \fIsrcCmd\fR.
|
||||
.TP
|
||||
\fIslave \fBbgerror\fR ?\fIcmdPrefix\fR?
|
||||
\fIchild \fBbgerror\fR ?\fIcmdPrefix\fR?
|
||||
.
|
||||
This command either gets or sets the current background exception handler
|
||||
for the \fIslave\fR interpreter. If \fIcmdPrefix\fR is
|
||||
for the \fIchild\fR interpreter. If \fIcmdPrefix\fR is
|
||||
absent, the current background exception handler is returned, and if it is
|
||||
present, it is a list of words (of minimum length one) that describes
|
||||
what to set the interpreter's background exception handler to. See the
|
||||
\fBBACKGROUND EXCEPTION HANDLING\fR section for more details.
|
||||
.TP
|
||||
\fIslave \fBeval \fIarg \fR?\fIarg ..\fR?
|
||||
\fIchild \fBeval \fIarg \fR?\fIarg ..\fR?
|
||||
.
|
||||
This command concatenates all of the \fIarg\fR arguments in
|
||||
the same fashion as the \fBconcat\fR command, then evaluates
|
||||
the resulting string as a Tcl script in \fIslave\fR.
|
||||
the resulting string as a Tcl script in \fIchild\fR.
|
||||
The result of this evaluation (including all \fBreturn\fR options,
|
||||
such as \fB\-errorinfo\fR and \fB\-errorcode\fR information, if an
|
||||
error occurs) is returned to the invoking interpreter.
|
||||
Note that the script will be executed in the current context stack frame
|
||||
of \fIslave\fR; this is so that the implementations (in a master
|
||||
interpreter) of aliases in a slave interpreter can execute scripts in
|
||||
the slave that find out information about the slave's current state
|
||||
of \fIchild\fR; this is so that the implementations (in a parent
|
||||
interpreter) of aliases in a child interpreter can execute scripts in
|
||||
the child that find out information about the child's current state
|
||||
and stack frame.
|
||||
.TP
|
||||
\fIslave \fBexpose \fIhiddenName \fR?\fIexposedCmdName\fR?
|
||||
\fIchild \fBexpose \fIhiddenName \fR?\fIexposedCmdName\fR?
|
||||
.
|
||||
This command exposes the hidden command \fIhiddenName\fR, eventually bringing
|
||||
it back under a new \fIexposedCmdName\fR name (this name is currently
|
||||
accepted only if it is a valid global name space name without any ::),
|
||||
in \fIslave\fR.
|
||||
in \fIchild\fR.
|
||||
If an exposed command with the targeted name already exists, this command
|
||||
fails.
|
||||
For more details on hidden commands, see \fBHIDDEN COMMANDS\fR, below.
|
||||
.TP
|
||||
\fIslave \fBhide \fIexposedCmdName\fR ?\fIhiddenCmdName\fR?
|
||||
\fIchild \fBhide \fIexposedCmdName\fR ?\fIhiddenCmdName\fR?
|
||||
.
|
||||
This command hides the exposed command \fIexposedCmdName\fR, renaming it to
|
||||
the hidden command \fIhiddenCmdName\fR, or keeping the same name if the
|
||||
argument is not given, in the \fIslave\fR interpreter.
|
||||
argument is not given, in the \fIchild\fR interpreter.
|
||||
If a hidden command with the targeted name already exists, this command
|
||||
fails.
|
||||
Currently both \fIexposedCmdName\fR and \fIhiddenCmdName\fR can
|
||||
not contain namespace qualifiers, or an error is raised.
|
||||
Commands to be hidden are looked up in the global
|
||||
namespace even if the current namespace is not the global one. This
|
||||
prevents slaves from fooling a master interpreter into hiding the wrong
|
||||
prevents children from fooling a parent interpreter into hiding the wrong
|
||||
command, by making the current namespace be different from the global one.
|
||||
For more details on hidden commands, see \fBHIDDEN COMMANDS\fR, below.
|
||||
.TP
|
||||
\fIslave \fBhidden\fR
|
||||
\fIchild \fBhidden\fR
|
||||
.
|
||||
Returns a list of the names of all hidden commands in \fIslave\fR.
|
||||
Returns a list of the names of all hidden commands in \fIchild\fR.
|
||||
.TP
|
||||
\fIslave \fBinvokehidden\fR ?\fI\-option ...\fR? \fIhiddenName \fR?\fIarg ..\fR?
|
||||
\fIchild \fBinvokehidden\fR ?\fI\-option ...\fR? \fIhiddenName \fR?\fIarg ..\fR?
|
||||
.
|
||||
This command invokes the hidden command \fIhiddenName\fR with the
|
||||
supplied arguments, in \fIslave\fR. No substitutions or evaluations are
|
||||
supplied arguments, in \fIchild\fR. No substitutions or evaluations are
|
||||
applied to the arguments. Three \fI\-option\fRs are supported, all
|
||||
of which start with \fB\-\fR: \fB\-namespace\fR (which takes a single
|
||||
argument afterwards, \fInsName\fR), \fB\-global\fR, and \fB\-\|\-\fR.
|
||||
If the \fB\-namespace\fR flag is given, the hidden command is invoked in
|
||||
the specified namespace in the slave.
|
||||
the specified namespace in the child.
|
||||
If the \fB\-global\fR flag is given, the command is invoked at the global
|
||||
level in the slave; otherwise it is invoked at the current call frame and
|
||||
level in the child; otherwise it is invoked at the current call frame and
|
||||
can access local variables in that or outer call frames.
|
||||
The \fB\-\|\-\fR flag allows the \fIhiddenCmdName\fR argument to start with a
|
||||
.QW \-
|
||||
@@ -519,37 +513,37 @@ character, and is otherwise unnecessary.
|
||||
If both the \fB\-namespace\fR and \fB\-global\fR flags are given, the
|
||||
\fB\-namespace\fR flag is ignored.
|
||||
Note that the hidden command will be executed (by default) in the
|
||||
current context stack frame of \fIslave\fR.
|
||||
current context stack frame of \fIchild\fR.
|
||||
For more details on hidden commands,
|
||||
see \fBHIDDEN COMMANDS\fR, below.
|
||||
.TP
|
||||
\fIslave \fBissafe\fR
|
||||
\fIchild \fBissafe\fR
|
||||
.
|
||||
Returns \fB1\fR if the slave interpreter is safe, \fB0\fR otherwise.
|
||||
Returns \fB1\fR if the child interpreter is safe, \fB0\fR otherwise.
|
||||
.TP
|
||||
\fIslave \fBlimit\fR \fIlimitType\fR ?\fI\-option\fR? ?\fIvalue\fR \fI...\fR?
|
||||
\fIchild \fBlimit\fR \fIlimitType\fR ?\fI\-option\fR? ?\fIvalue\fR \fI...\fR?
|
||||
.
|
||||
Sets up, manipulates and queries the configuration of the resource
|
||||
limit \fIlimitType\fR for the slave interpreter. If no \fI\-option\fR
|
||||
limit \fIlimitType\fR for the child interpreter. If no \fI\-option\fR
|
||||
is specified, return the current configuration of the limit. If
|
||||
\fI\-option\fR is the sole argument, return the value of that option.
|
||||
Otherwise, a list of \fI\-option\fR/\fIvalue\fR argument pairs must
|
||||
supplied. See \fBRESOURCE LIMITS\fR below for a more detailed explanation of
|
||||
what limits and options are supported.
|
||||
.TP
|
||||
\fIslave \fBmarktrusted\fR
|
||||
\fIchild \fBmarktrusted\fR
|
||||
.
|
||||
Marks the slave interpreter as trusted. Can only be invoked by a
|
||||
Marks the child interpreter as trusted. Can only be invoked by a
|
||||
trusted interpreter. This command does not expose any hidden
|
||||
commands in the slave interpreter. The command has no effect if the slave
|
||||
commands in the child interpreter. The command has no effect if the child
|
||||
is already trusted.
|
||||
.TP
|
||||
\fIslave\fR \fBrecursionlimit\fR ?\fInewlimit\fR?
|
||||
\fIchild\fR \fBrecursionlimit\fR ?\fInewlimit\fR?
|
||||
.
|
||||
Returns the maximum allowable nesting depth for the \fIslave\fR interpreter.
|
||||
If \fInewlimit\fR is specified, the recursion limit in \fIslave\fR will be
|
||||
Returns the maximum allowable nesting depth for the \fIchild\fR interpreter.
|
||||
If \fInewlimit\fR is specified, the recursion limit in \fIchild\fR will be
|
||||
set so that nesting of more than \fInewlimit\fR calls to \fBTcl_Eval()\fR
|
||||
and related procedures in \fIslave\fR will return an error.
|
||||
and related procedures in \fIchild\fR will return an error.
|
||||
The \fInewlimit\fR value is also returned.
|
||||
The \fInewlimit\fR value must be a positive integer between 1 and the
|
||||
maximum value of a non-long integer on the platform.
|
||||
@@ -573,14 +567,14 @@ For example, commands to create files on disk are removed, and the
|
||||
\fBexec\fR command is removed, since it could be used to cause damage
|
||||
through subprocesses.
|
||||
Limited access to these facilities can be provided, by creating
|
||||
aliases to the master interpreter which check their arguments carefully
|
||||
aliases to the parent interpreter which check their arguments carefully
|
||||
and provide restricted access to a safe subset of facilities.
|
||||
For example, file creation might be allowed in a particular subdirectory
|
||||
and subprocess invocation might be allowed for a carefully selected and
|
||||
fixed set of programs.
|
||||
.PP
|
||||
A safe interpreter is created by specifying the \fB\-safe\fR switch
|
||||
to the \fBinterp create\fR command. Furthermore, any slave created
|
||||
to the \fBinterp create\fR command. Furthermore, any child created
|
||||
by a safe interpreter will also be safe.
|
||||
.PP
|
||||
A safe interpreter is created with exactly the following set of
|
||||
@@ -668,14 +662,14 @@ including itself.
|
||||
.PP
|
||||
The alias mechanism has been carefully designed so that it can
|
||||
be used safely when an untrusted script is executing
|
||||
in a safe slave and the target of the alias is a trusted
|
||||
master. The most important thing in guaranteeing safety is to
|
||||
ensure that information passed from the slave to the master is
|
||||
never evaluated or substituted in the master; if this were to
|
||||
occur, it would enable an evil script in the slave to invoke
|
||||
arbitrary functions in the master, which would compromise security.
|
||||
in a safe child and the target of the alias is a trusted
|
||||
parent. The most important thing in guaranteeing safety is to
|
||||
ensure that information passed from the child to the parent is
|
||||
never evaluated or substituted in the parent; if this were to
|
||||
occur, it would enable an evil script in the child to invoke
|
||||
arbitrary functions in the parent, which would compromise security.
|
||||
.PP
|
||||
When the source for an alias is invoked in the slave interpreter, the
|
||||
When the source for an alias is invoked in the child interpreter, the
|
||||
usual Tcl substitutions are performed when parsing that command.
|
||||
These substitutions are carried out in the source interpreter just
|
||||
as they would be for any other command invoked in that interpreter.
|
||||
@@ -702,8 +696,8 @@ the alias's source command is parsed in the source interpreter.
|
||||
When writing the \fItargetCmd\fRs for aliases in safe interpreters,
|
||||
it is very important that the arguments to that command never be
|
||||
evaluated or substituted, since this would provide an escape
|
||||
mechanism whereby the slave interpreter could execute arbitrary
|
||||
code in the master. This in turn would compromise the security
|
||||
mechanism whereby the child interpreter could execute arbitrary
|
||||
code in the parent. This in turn would compromise the security
|
||||
of the system.
|
||||
.SH "HIDDEN COMMANDS"
|
||||
.PP
|
||||
@@ -730,28 +724,28 @@ invoke\fR. Hidden commands and exposed commands reside in separate name
|
||||
spaces. It is possible to define a hidden command and an exposed command by
|
||||
the same name within one interpreter.
|
||||
.PP
|
||||
Hidden commands in a slave interpreter can be invoked in the body of
|
||||
procedures called in the master during alias invocation. For example, an
|
||||
alias for \fBsource\fR could be created in a slave interpreter. When it is
|
||||
invoked in the slave interpreter, a procedure is called in the master
|
||||
Hidden commands in a child interpreter can be invoked in the body of
|
||||
procedures called in the parent during alias invocation. For example, an
|
||||
alias for \fBsource\fR could be created in a child interpreter. When it is
|
||||
invoked in the child interpreter, a procedure is called in the parent
|
||||
interpreter to check that the operation is allowable (e.g. it asks to
|
||||
source a file that the slave interpreter is allowed to access). The
|
||||
procedure then it invokes the hidden \fBsource\fR command in the slave
|
||||
source a file that the child interpreter is allowed to access). The
|
||||
procedure then it invokes the hidden \fBsource\fR command in the child
|
||||
interpreter to actually source in the contents of the file. Note that two
|
||||
commands named \fBsource\fR exist in the slave interpreter: the alias, and
|
||||
commands named \fBsource\fR exist in the child interpreter: the alias, and
|
||||
the hidden command.
|
||||
.PP
|
||||
Because a master interpreter may invoke a hidden command as part of
|
||||
Because a parent interpreter may invoke a hidden command as part of
|
||||
handling an alias invocation, great care must be taken to avoid evaluating
|
||||
any arguments passed in through the alias invocation.
|
||||
Otherwise, malicious slave interpreters could cause a trusted master
|
||||
Otherwise, malicious child interpreters could cause a trusted parent
|
||||
interpreter to execute dangerous commands on their behalf. See the section
|
||||
on \fBALIAS INVOCATION\fR for a more complete discussion of this topic.
|
||||
To help avoid this problem, no substitutions or evaluations are
|
||||
applied to arguments of \fBinterp invokehidden\fR.
|
||||
.PP
|
||||
Safe interpreters are not allowed to invoke hidden commands in themselves
|
||||
or in their descendants. This prevents safe slaves from gaining access to
|
||||
or in their descendants. This prevents safe children from gaining access to
|
||||
hidden functionality in themselves or their descendants.
|
||||
.PP
|
||||
The set of hidden commands in an interpreter can be manipulated by a trusted
|
||||
@@ -770,12 +764,12 @@ qualifiers, and you must first rename a command in a namespace to the
|
||||
global namespace before you can hide it.
|
||||
Commands to be hidden by \fBinterp hide\fR are looked up in the global
|
||||
namespace even if the current namespace is not the global one. This
|
||||
prevents slaves from fooling a master interpreter into hiding the wrong
|
||||
prevents children from fooling a parent interpreter into hiding the wrong
|
||||
command, by making the current namespace be different from the global one.
|
||||
.SH "RESOURCE LIMITS"
|
||||
.PP
|
||||
Every interpreter has two kinds of resource limits that may be imposed by any
|
||||
master interpreter upon its slaves. Command limits (of type \fBcommand\fR)
|
||||
parent interpreter upon its children. Command limits (of type \fBcommand\fR)
|
||||
restrict the total number of Tcl commands that may be executed by an
|
||||
interpreter (as can be inspected via the \fBinfo cmdcount\fR command), and
|
||||
time limits (of type \fBtime\fR) place a limit by which execution within the
|
||||
@@ -784,7 +778,7 @@ interpreter must complete. Note that time limits are expressed as
|
||||
\fBafter\fR) because they may be modified after creation.
|
||||
.PP
|
||||
When a limit is exceeded for an interpreter, first any handler callbacks
|
||||
defined by master interpreters are called. If those callbacks increase or
|
||||
defined by parent interpreters are called. If those callbacks increase or
|
||||
remove the limit, execution within the (previously) limited interpreter
|
||||
continues. If the limit is still in force, an error is generated at that point
|
||||
and normal processing of errors within the interpreter (by the \fBcatch\fR
|
||||
@@ -841,13 +835,13 @@ This option specifies the number of commands that the interpreter may execute
|
||||
before triggering the command limit. This option may be the empty string,
|
||||
which indicates that a command limit is not set for the interpreter.
|
||||
.PP
|
||||
Where an interpreter with a resource limit set on it creates a slave
|
||||
interpreter, that slave interpreter will have resource limits imposed on it
|
||||
that are at least as restrictive as the limits on the creating master
|
||||
interpreter. If the master interpreter of the limited master wishes to relax
|
||||
Where an interpreter with a resource limit set on it creates a child
|
||||
interpreter, that child interpreter will have resource limits imposed on it
|
||||
that are at least as restrictive as the limits on the creating parent
|
||||
interpreter. If the parent interpreter of the limited parent wishes to relax
|
||||
these conditions, it should hide the \fBinterp\fR command in the child and
|
||||
then use aliases and the \fBinterp invokehidden\fR subcommand to provide such
|
||||
access as it chooses to the \fBinterp\fR command to the limited master as
|
||||
access as it chooses to the \fBinterp\fR command to the limited parent as
|
||||
necessary.
|
||||
.SH "BACKGROUND EXCEPTION HANDLING"
|
||||
.PP
|
||||
@@ -908,9 +902,9 @@ set i [\fBinterp create\fR]
|
||||
}
|
||||
.CE
|
||||
.SH "SEE ALSO"
|
||||
bgerror(n), load(n), safe(n), Tcl_CreateSlave(3), Tcl_Eval(3), Tcl_BackgroundException(3)
|
||||
bgerror(n), load(n), safe(n), Tcl_CreateChild(3), Tcl_Eval(3), Tcl_BackgroundException(3)
|
||||
.SH KEYWORDS
|
||||
alias, master interpreter, safe interpreter, slave interpreter
|
||||
alias, parent interpreter, safe interpreter, child interpreter
|
||||
'\"Local Variables:
|
||||
'\"mode: nroff
|
||||
'\"End:
|
||||
|
||||
+1
-1
@@ -124,7 +124,7 @@ will read all the \fB.tcl\fR files in subdirectory \fBfoo\fR and
|
||||
generate a new index file \fBfoo/tclIndex\fR.
|
||||
.PP
|
||||
\fBAuto_mkindex\fR parses the Tcl scripts by sourcing them into a
|
||||
slave interpreter and monitoring the proc and namespace commands that
|
||||
child interpreter and monitoring the proc and namespace commands that
|
||||
are executed. Extensions can use the (undocumented)
|
||||
auto_mkindex_parser package to register other commands that can
|
||||
contribute to the auto_load index. You will have to read through
|
||||
|
||||
+2
-2
@@ -42,7 +42,7 @@ The default pattern is \fB*.tcl\fR and \fB*.[info sharedlibextension]\fR.
|
||||
\fBPkg_mkIndex\fR will create a file \fBpkgIndex.tcl\fR in \fIdir\fR
|
||||
with package information about all the files given by the \fIpattern\fR
|
||||
arguments.
|
||||
It does this by loading each file into a slave
|
||||
It does this by loading each file into a child
|
||||
interpreter and seeing what packages
|
||||
and new commands appear (this is why it is essential to have
|
||||
\fBpackage provide\fR commands or \fBTcl_PkgProvide\fR calls
|
||||
@@ -109,7 +109,7 @@ the use of \fIauto_reset\fR, and therefore its use is discouraged.
|
||||
.TP 15
|
||||
\fB\-load \fIpkgPat\fR
|
||||
The index process will pre-load any packages that exist in the
|
||||
current interpreter and match \fIpkgPat\fR into the slave interpreter used to
|
||||
current interpreter and match \fIpkgPat\fR into the child interpreter used to
|
||||
generate the index. The pattern match uses string match rules, but without
|
||||
making case distinctions.
|
||||
See \fBCOMPLEX CASES\fR below.
|
||||
|
||||
+50
-50
@@ -11,17 +11,17 @@
|
||||
.SH NAME
|
||||
safe \- Creating and manipulating safe interpreters
|
||||
.SH SYNOPSIS
|
||||
\fB::safe::interpCreate\fR ?\fIslave\fR? ?\fIoptions...\fR?
|
||||
\fB::safe::interpCreate\fR ?\fIchild\fR? ?\fIoptions...\fR?
|
||||
.sp
|
||||
\fB::safe::interpInit\fR \fIslave\fR ?\fIoptions...\fR?
|
||||
\fB::safe::interpInit\fR \fIchild\fR ?\fIoptions...\fR?
|
||||
.sp
|
||||
\fB::safe::interpConfigure\fR \fIslave\fR ?\fIoptions...\fR?
|
||||
\fB::safe::interpConfigure\fR \fIchild\fR ?\fIoptions...\fR?
|
||||
.sp
|
||||
\fB::safe::interpDelete\fR \fIslave\fR
|
||||
\fB::safe::interpDelete\fR \fIchild\fR
|
||||
.sp
|
||||
\fB::safe::interpAddToAccessPath\fR \fIslave\fR \fIdirectory\fR
|
||||
\fB::safe::interpAddToAccessPath\fR \fIchild\fR \fIdirectory\fR
|
||||
.sp
|
||||
\fB::safe::interpFindInAccessPath\fR \fIslave\fR \fIdirectory\fR
|
||||
\fB::safe::interpFindInAccessPath\fR \fIchild\fR \fIdirectory\fR
|
||||
.sp
|
||||
\fB::safe::setLogCmd\fR ?\fIcmd arg...\fR?
|
||||
.SS OPTIONS
|
||||
@@ -44,7 +44,7 @@ application or computer. Untrusted scripts are also prevented from
|
||||
disclosing information stored on the hosting computer or in the
|
||||
hosting application to any party.
|
||||
.PP
|
||||
Safe Tcl allows a master interpreter to create safe, restricted
|
||||
Safe Tcl allows a parent interpreter to create safe, restricted
|
||||
interpreters that contain a set of predefined aliases for the \fBsource\fR,
|
||||
\fBload\fR, \fBfile\fR, \fBencoding\fR, and \fBexit\fR commands and
|
||||
are able to use the auto-loading and package mechanisms.
|
||||
@@ -53,39 +53,39 @@ No knowledge of the file system structure is leaked to the
|
||||
safe interpreter, because it has access only to a virtualized path
|
||||
containing tokens. When the safe interpreter requests to source a file, it
|
||||
uses the token in the virtual path as part of the file name to source; the
|
||||
master interpreter transparently
|
||||
parent interpreter transparently
|
||||
translates the token into a real directory name and executes the
|
||||
requested operation (see the section \fBSECURITY\fR below for details).
|
||||
Different levels of security can be selected by using the optional flags
|
||||
of the commands described below.
|
||||
.PP
|
||||
All commands provided in the master interpreter by Safe Tcl reside in
|
||||
All commands provided in the parent interpreter by Safe Tcl reside in
|
||||
the \fBsafe\fR namespace.
|
||||
.SH COMMANDS
|
||||
The following commands are provided in the master interpreter:
|
||||
The following commands are provided in the parent interpreter:
|
||||
.TP
|
||||
\fB::safe::interpCreate\fR ?\fIslave\fR? ?\fIoptions...\fR?
|
||||
\fB::safe::interpCreate\fR ?\fIchild\fR? ?\fIoptions...\fR?
|
||||
Creates a safe interpreter, installs the aliases described in the section
|
||||
\fBALIASES\fR and initializes the auto-loading and package mechanism as
|
||||
specified by the supplied \fIoptions\fR.
|
||||
See the \fBOPTIONS\fR section below for a description of the
|
||||
optional arguments.
|
||||
If the \fIslave\fR argument is omitted, a name will be generated.
|
||||
If the \fIchild\fR argument is omitted, a name will be generated.
|
||||
\fB::safe::interpCreate\fR always returns the interpreter name.
|
||||
.TP
|
||||
\fB::safe::interpInit\fR \fIslave\fR ?\fIoptions...\fR?
|
||||
\fB::safe::interpInit\fR \fIchild\fR ?\fIoptions...\fR?
|
||||
This command is similar to \fBinterpCreate\fR except it that does not
|
||||
create the safe interpreter. \fIslave\fR must have been created by some
|
||||
create the safe interpreter. \fIchild\fR must have been created by some
|
||||
other means, like \fBinterp create\fR \fB\-safe\fR.
|
||||
.TP
|
||||
\fB::safe::interpConfigure\fR \fIslave\fR ?\fIoptions...\fR?
|
||||
\fB::safe::interpConfigure\fR \fIchild\fR ?\fIoptions...\fR?
|
||||
If no \fIoptions\fR are given, returns the settings for all options for the
|
||||
named safe interpreter as a list of options and their current values
|
||||
for that \fIslave\fR.
|
||||
for that \fIchild\fR.
|
||||
If a single additional argument is provided,
|
||||
it will return a list of 2 elements \fIname\fR and \fIvalue\fR where
|
||||
\fIname\fR is the full name of that option and \fIvalue\fR the current value
|
||||
for that option and the \fIslave\fR.
|
||||
for that option and the \fIchild\fR.
|
||||
If more than two additional arguments are provided, it will reconfigure the
|
||||
safe interpreter and change each and only the provided options.
|
||||
See the section on \fBOPTIONS\fR below for options description.
|
||||
@@ -105,14 +105,14 @@ safe::interpConfigure $i0 \-delete {foo bar} \-statics 0
|
||||
.CE
|
||||
.RE
|
||||
.TP
|
||||
\fB::safe::interpDelete\fR \fIslave\fR
|
||||
\fB::safe::interpDelete\fR \fIchild\fR
|
||||
Deletes the safe interpreter and cleans up the corresponding
|
||||
master interpreter data structures.
|
||||
parent interpreter data structures.
|
||||
If a \fIdeleteHook\fR script was specified for this interpreter it is
|
||||
evaluated before the interpreter is deleted, with the name of the
|
||||
interpreter as an additional argument.
|
||||
.TP
|
||||
\fB::safe::interpFindInAccessPath\fR \fIslave\fR \fIdirectory\fR
|
||||
\fB::safe::interpFindInAccessPath\fR \fIchild\fR \fIdirectory\fR
|
||||
This command finds and returns the token for the real directory
|
||||
\fIdirectory\fR in the safe interpreter's current virtual access path.
|
||||
It generates an error if the directory is not found.
|
||||
@@ -120,14 +120,14 @@ Example of use:
|
||||
.RS
|
||||
.PP
|
||||
.CS
|
||||
$slave eval [list set tk_library \e
|
||||
$child eval [list set tk_library \e
|
||||
[::safe::interpFindInAccessPath $name $tk_library]]
|
||||
.CE
|
||||
.RE
|
||||
.TP
|
||||
\fB::safe::interpAddToAccessPath\fR \fIslave\fR \fIdirectory\fR
|
||||
\fB::safe::interpAddToAccessPath\fR \fIchild\fR \fIdirectory\fR
|
||||
This command adds \fIdirectory\fR to the virtual path maintained for the
|
||||
safe interpreter in the master, and returns the token that can be used in
|
||||
safe interpreter in the parent, and returns the token that can be used in
|
||||
the safe interpreter to obtain access to files in that directory.
|
||||
If the directory is already in the virtual path, it only returns the token
|
||||
without adding the directory to the virtual path again.
|
||||
@@ -135,7 +135,7 @@ Example of use:
|
||||
.RS
|
||||
.PP
|
||||
.CS
|
||||
$slave eval [list set tk_library \e
|
||||
$child eval [list set tk_library \e
|
||||
[::safe::interpAddToAccessPath $name $tk_library]]
|
||||
.CE
|
||||
.RE
|
||||
@@ -168,10 +168,10 @@ Note that the safe interpreter only received an error message saying that
|
||||
the file was not found:
|
||||
.PP
|
||||
.CS
|
||||
NOTICE for slave interp10 : Created
|
||||
NOTICE for slave interp10 : Setting accessPath=(/foo/bar) staticsok=1 nestedok=0 deletehook=()
|
||||
NOTICE for slave interp10 : auto_path in interp10 has been set to {$p(:0:)}
|
||||
ERROR for slave interp10 : /foo/bar/init.tcl: no such file or directory
|
||||
NOTICE for child interp10 : Created
|
||||
NOTICE for child interp10 : Setting accessPath=(/foo/bar) staticsok=1 nestedok=0 deletehook=()
|
||||
NOTICE for child interp10 : auto_path in interp10 has been set to {$p(:0:)}
|
||||
ERROR for child interp10 : /foo/bar/init.tcl: no such file or directory
|
||||
.CE
|
||||
.RE
|
||||
.SS OPTIONS
|
||||
@@ -187,7 +187,7 @@ This option sets the list of directories from which the safe interpreter
|
||||
can \fBsource\fR and \fBload\fR files.
|
||||
If this option is not specified, or if it is given as the
|
||||
empty list, the safe interpreter will use the same directories as its
|
||||
master for auto-loading.
|
||||
parent for auto-loading.
|
||||
See the section \fBSECURITY\fR below for more detail about virtual paths,
|
||||
tokens and access control.
|
||||
.TP
|
||||
@@ -216,7 +216,7 @@ to load packages into its own sub-interpreters.
|
||||
.TP
|
||||
\fB\-deleteHook\fR \fIscript\fR
|
||||
When this option is given a non-empty \fIscript\fR, it will be
|
||||
evaluated in the master with the name of
|
||||
evaluated in the parent with the name of
|
||||
the safe interpreter as an additional argument
|
||||
just before actually deleting the safe interpreter.
|
||||
Giving an empty value removes any currently installed deletion hook
|
||||
@@ -281,8 +281,8 @@ potential for information leakage about its directory structure.
|
||||
To prevent this, commands that take file names as arguments in a safe
|
||||
interpreter use tokens instead of the real directory names.
|
||||
These tokens are translated to the real directory name while a request to,
|
||||
e.g., source a file is mediated by the master interpreter.
|
||||
This virtual path system is maintained in the master interpreter for each safe
|
||||
e.g., source a file is mediated by the parent interpreter.
|
||||
This virtual path system is maintained in the parent interpreter for each safe
|
||||
interpreter created by \fB::safe::interpCreate\fR or initialized by
|
||||
\fB::safe::interpInit\fR and
|
||||
the path maps tokens accessible in the safe interpreter into real path
|
||||
@@ -291,7 +291,7 @@ from gaining knowledge about the
|
||||
structure of the file system of the host on which the interpreter is
|
||||
executing.
|
||||
The only valid file names arguments
|
||||
for the \fBsource\fR and \fBload\fR aliases provided to the slave
|
||||
for the \fBsource\fR and \fBload\fR aliases provided to the child
|
||||
are path in the form of
|
||||
\fB[file join \fItoken filename\fB]\fR (i.e. when using the
|
||||
native file path formats: \fItoken\fB/\fIfilename\fR
|
||||
@@ -320,26 +320,26 @@ or be called
|
||||
.PP
|
||||
Each element of the initial access path
|
||||
list will be assigned a token that will be set in
|
||||
the slave \fBauto_path\fR and the first element of that list will be set as
|
||||
the \fBtcl_library\fR for that slave.
|
||||
the child \fBauto_path\fR and the first element of that list will be set as
|
||||
the \fBtcl_library\fR for that child.
|
||||
.PP
|
||||
If the access path argument is not given or is the empty list,
|
||||
the default behavior is to let the slave access the same packages
|
||||
as the master has access to (Or to be more precise:
|
||||
the default behavior is to let the child access the same packages
|
||||
as the parent has access to (Or to be more precise:
|
||||
only packages written in Tcl (which by definition cannot be dangerous
|
||||
as they run in the slave interpreter) and C extensions that
|
||||
provides a _SafeInit entry point). For that purpose, the master's
|
||||
\fBauto_path\fR will be used to construct the slave access path.
|
||||
In order that the slave successfully loads the Tcl library files
|
||||
as they run in the child interpreter) and C extensions that
|
||||
provides a _SafeInit entry point). For that purpose, the parent's
|
||||
\fBauto_path\fR will be used to construct the child access path.
|
||||
In order that the child successfully loads the Tcl library files
|
||||
(which includes the auto-loading mechanism itself) the \fBtcl_library\fR will be
|
||||
added or moved to the first position if necessary, in the
|
||||
slave access path, so the slave
|
||||
\fBtcl_library\fR will be the same as the master's (its real
|
||||
path will still be invisible to the slave though).
|
||||
In order that auto-loading works the same for the slave and
|
||||
the master in this by default case, the first-level
|
||||
sub directories of each directory in the master \fBauto_path\fR will
|
||||
also be added (if not already included) to the slave access path.
|
||||
child access path, so the child
|
||||
\fBtcl_library\fR will be the same as the parent's (its real
|
||||
path will still be invisible to the child though).
|
||||
In order that auto-loading works the same for the child and
|
||||
the parent in this by default case, the first-level
|
||||
sub directories of each directory in the parent \fBauto_path\fR will
|
||||
also be added (if not already included) to the child access path.
|
||||
You can always specify a more
|
||||
restrictive path for which sub directories will never be searched by
|
||||
explicitly specifying your directory list with the \fB\-accessPath\fR flag
|
||||
@@ -352,8 +352,8 @@ to synchronize its \fBauto_index\fR with the new token list.
|
||||
.SH "SEE ALSO"
|
||||
interp(n), library(n), load(n), package(n), source(n), unknown(n)
|
||||
.SH KEYWORDS
|
||||
alias, auto\-loading, auto_mkindex, load, master interpreter, safe
|
||||
interpreter, slave interpreter, source
|
||||
alias, auto\-loading, auto_mkindex, load, parent interpreter, safe
|
||||
interpreter, child interpreter, source
|
||||
'\" Local Variables:
|
||||
'\" mode: nroff
|
||||
'\" End:
|
||||
|
||||
+8
-8
@@ -203,7 +203,7 @@ array. Returns an empty string.
|
||||
.TP
|
||||
\fBrunAllTests\fR
|
||||
.
|
||||
This is a master command meant to run an entire suite of tests,
|
||||
This is a main command meant to run an entire suite of tests,
|
||||
spanning multiple files and/or directories, as governed by
|
||||
the configurable options of \fBtcltest\fR. See \fBRUNNING ALL TESTS\fR
|
||||
below for a complete description of the many variations possible
|
||||
@@ -804,17 +804,17 @@ then a copy of \fBinterpreter\fR will be \fBexec\fR'd to
|
||||
evaluate each file. The multi-process operation is useful
|
||||
when testing can cause errors so severe that a process
|
||||
terminates. Although such an error may terminate a child
|
||||
process evaluating one file, the master process can continue
|
||||
process evaluating one file, the main process can continue
|
||||
with the rest of the test suite. In multi-process operation,
|
||||
the configuration of \fBtcltest\fR in the master process is
|
||||
the configuration of \fBtcltest\fR in the main process is
|
||||
passed to the child processes as command line arguments,
|
||||
with the exception of \fBconfigure \-outfile\fR. The
|
||||
\fBrunAllTests\fR command in the
|
||||
master process collects all output from the child processes
|
||||
and collates their results into one master report. Any
|
||||
main process collects all output from the child processes
|
||||
and collates their results into one main report. Any
|
||||
reports of individual test failures, or messages requested
|
||||
by a \fBconfigure \-verbose\fR setting are passed directly
|
||||
on to \fBoutputChannel\fR by the master process.
|
||||
on to \fBoutputChannel\fR by the main process.
|
||||
.PP
|
||||
After evaluating all selected test files, a summary of the
|
||||
results is printed to \fBoutputChannel\fR. The summary
|
||||
@@ -1134,7 +1134,7 @@ A good namespace to use is a child namespace \fBtest\fR of the namespace
|
||||
of the module you are testing.
|
||||
.PP
|
||||
A test file should also be able to be evaluated directly as a script,
|
||||
not depending on being called by a master \fBrunAllTests\fR. This
|
||||
not depending on being called by a main \fBrunAllTests\fR. This
|
||||
means that each test file should process command line arguments to give
|
||||
the tester all the configuration control that \fBtcltest\fR provides.
|
||||
.PP
|
||||
@@ -1175,7 +1175,7 @@ doing any necessary setup. This script is usually named \fBall.tcl\fR
|
||||
because that is the default name used by \fBrunAllTests\fR when combining
|
||||
multiple test suites into one testing run.
|
||||
.IP [8]
|
||||
Here is a sketch of a sample test suite master script:
|
||||
Here is a sketch of a sample test suite main script:
|
||||
.RS
|
||||
.PP
|
||||
.CS
|
||||
|
||||
+1
-1
@@ -73,7 +73,7 @@ struct dfa {
|
||||
chr *lastnopr; /* location of last cache-flushed NOPROGRESS */
|
||||
struct sset *search; /* replacement-search-pointer memory */
|
||||
int cptsmalloced; /* were the areas individually malloced? */
|
||||
char *mallocarea; /* self, or master malloced area, or NULL */
|
||||
char *mallocarea; /* self, or main malloced area, or NULL */
|
||||
};
|
||||
|
||||
#define WORK 1 /* number of work bitvectors needed */
|
||||
|
||||
+7
-7
@@ -316,12 +316,12 @@ declare 85 {
|
||||
int flags)
|
||||
}
|
||||
declare 86 {
|
||||
int Tcl_CreateAlias(Tcl_Interp *slave, const char *slaveCmd,
|
||||
int Tcl_CreateAlias(Tcl_Interp *child, const char *childCmd,
|
||||
Tcl_Interp *target, const char *targetCmd, int argc,
|
||||
CONST84 char *const *argv)
|
||||
}
|
||||
declare 87 {
|
||||
int Tcl_CreateAliasObj(Tcl_Interp *slave, const char *slaveCmd,
|
||||
int Tcl_CreateAliasObj(Tcl_Interp *child, const char *childCmd,
|
||||
Tcl_Interp *target, const char *targetCmd, int objc,
|
||||
Tcl_Obj *const objv[])
|
||||
}
|
||||
@@ -364,7 +364,7 @@ declare 96 {
|
||||
Tcl_CmdDeleteProc *deleteProc)
|
||||
}
|
||||
declare 97 {
|
||||
Tcl_Interp *Tcl_CreateSlave(Tcl_Interp *interp, const char *slaveName,
|
||||
Tcl_Interp *Tcl_CreateSlave(Tcl_Interp *interp, const char *name,
|
||||
int isSafe)
|
||||
}
|
||||
declare 98 {
|
||||
@@ -527,12 +527,12 @@ declare 147 {
|
||||
void Tcl_FreeResult(Tcl_Interp *interp)
|
||||
}
|
||||
declare 148 {
|
||||
int Tcl_GetAlias(Tcl_Interp *interp, const char *slaveCmd,
|
||||
int Tcl_GetAlias(Tcl_Interp *interp, const char *childCmd,
|
||||
Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr,
|
||||
int *argcPtr, CONST84 char ***argvPtr)
|
||||
}
|
||||
declare 149 {
|
||||
int Tcl_GetAliasObj(Tcl_Interp *interp, const char *slaveCmd,
|
||||
int Tcl_GetAliasObj(Tcl_Interp *interp, const char *childCmd,
|
||||
Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr,
|
||||
int *objcPtr, Tcl_Obj ***objv)
|
||||
}
|
||||
@@ -582,7 +582,7 @@ declare 162 {
|
||||
CONST84_RETURN char *Tcl_GetHostName(void)
|
||||
}
|
||||
declare 163 {
|
||||
int Tcl_GetInterpPath(Tcl_Interp *interp, Tcl_Interp *slaveInterp)
|
||||
int Tcl_GetInterpPath(Tcl_Interp *interp, Tcl_Interp *childInterp)
|
||||
}
|
||||
declare 164 {
|
||||
Tcl_Interp *Tcl_GetMaster(Tcl_Interp *interp)
|
||||
@@ -616,7 +616,7 @@ declare 171 {
|
||||
int Tcl_GetServiceMode(void)
|
||||
}
|
||||
declare 172 {
|
||||
Tcl_Interp *Tcl_GetSlave(Tcl_Interp *interp, const char *slaveName)
|
||||
Tcl_Interp *Tcl_GetSlave(Tcl_Interp *interp, const char *name)
|
||||
}
|
||||
declare 173 {
|
||||
Tcl_Channel Tcl_GetStdChannel(int type)
|
||||
|
||||
+4
-4
@@ -3443,11 +3443,11 @@ CancelEvalProc(
|
||||
TclSetCancelFlags(iPtr, cancelInfo->flags | CANCELED);
|
||||
|
||||
/*
|
||||
* Now, we must set the script cancellation flags on all the slave
|
||||
* Now, we must set the script cancellation flags on all the child
|
||||
* interpreters belonging to this one.
|
||||
*/
|
||||
|
||||
TclSetSlaveCancelFlags((Tcl_Interp *) iPtr,
|
||||
TclSetChildCancelFlags((Tcl_Interp *) iPtr,
|
||||
cancelInfo->flags | CANCELED, 0);
|
||||
|
||||
/*
|
||||
@@ -3966,7 +3966,7 @@ TclResetCancellation(
|
||||
* Tcl_Canceled --
|
||||
*
|
||||
* Check if the script in progress has been canceled, i.e.,
|
||||
* Tcl_CancelEval was called for this interpreter or any of its master
|
||||
* Tcl_CancelEval was called for this interpreter or any of its parent
|
||||
* interpreters.
|
||||
*
|
||||
* Results:
|
||||
@@ -5046,7 +5046,7 @@ TclEvalEx(
|
||||
* the embedded command, which is refered to
|
||||
* by 'script'. The 'clNextOuter' refers to
|
||||
* the current entry in the table of
|
||||
* continuation lines in this "master script",
|
||||
* continuation lines in this "parent script",
|
||||
* and the character offsets are relative to
|
||||
* the 'outerScript' as well.
|
||||
*
|
||||
|
||||
+1
-1
@@ -263,7 +263,7 @@ TclClockInit(
|
||||
};
|
||||
|
||||
/*
|
||||
* Safe interps get [::clock] as alias to a master, so do not need their
|
||||
* Safe interps get [::clock] as alias to a parent, so do not need their
|
||||
* own copies of the support routines.
|
||||
*/
|
||||
|
||||
|
||||
+1
-1
@@ -1054,7 +1054,7 @@ InfoErrorStackCmd(
|
||||
|
||||
target = interp;
|
||||
if (objc == 2) {
|
||||
target = Tcl_GetSlave(interp, Tcl_GetString(objv[1]));
|
||||
target = Tcl_GetChild(interp, Tcl_GetString(objv[1]));
|
||||
if (target == NULL) {
|
||||
return TCL_ERROR;
|
||||
}
|
||||
|
||||
@@ -827,7 +827,7 @@ TclSetByteCodeFromAny(
|
||||
* faster code in some cases, and more compact code in more.
|
||||
*/
|
||||
|
||||
if (Tcl_GetMaster(interp) == NULL &&
|
||||
if (Tcl_GetParent(interp) == NULL &&
|
||||
!Tcl_LimitTypeEnabled(interp, TCL_LIMIT_COMMANDS|TCL_LIMIT_TIME)
|
||||
&& IsCompactibleCompileEnv(interp, &compEnv)) {
|
||||
TclFreeCompileEnv(&compEnv);
|
||||
|
||||
+17
-18
@@ -279,13 +279,13 @@ EXTERN int Tcl_ConvertElement(const char *src, char *dst,
|
||||
EXTERN int Tcl_ConvertCountedElement(const char *src,
|
||||
int length, char *dst, int flags);
|
||||
/* 86 */
|
||||
EXTERN int Tcl_CreateAlias(Tcl_Interp *slave,
|
||||
const char *slaveCmd, Tcl_Interp *target,
|
||||
EXTERN int Tcl_CreateAlias(Tcl_Interp *child,
|
||||
const char *childCmd, Tcl_Interp *target,
|
||||
const char *targetCmd, int argc,
|
||||
CONST84 char *const *argv);
|
||||
/* 87 */
|
||||
EXTERN int Tcl_CreateAliasObj(Tcl_Interp *slave,
|
||||
const char *slaveCmd, Tcl_Interp *target,
|
||||
EXTERN int Tcl_CreateAliasObj(Tcl_Interp *child,
|
||||
const char *childCmd, Tcl_Interp *target,
|
||||
const char *targetCmd, int objc,
|
||||
Tcl_Obj *const objv[]);
|
||||
/* 88 */
|
||||
@@ -323,8 +323,8 @@ EXTERN Tcl_Command Tcl_CreateObjCommand(Tcl_Interp *interp,
|
||||
ClientData clientData,
|
||||
Tcl_CmdDeleteProc *deleteProc);
|
||||
/* 97 */
|
||||
EXTERN Tcl_Interp * Tcl_CreateSlave(Tcl_Interp *interp,
|
||||
const char *slaveName, int isSafe);
|
||||
EXTERN Tcl_Interp * Tcl_CreateSlave(Tcl_Interp *interp, const char *name,
|
||||
int isSafe);
|
||||
/* 98 */
|
||||
EXTERN Tcl_TimerToken Tcl_CreateTimerHandler(int milliseconds,
|
||||
Tcl_TimerProc *proc, ClientData clientData);
|
||||
@@ -458,13 +458,13 @@ EXTERN int Tcl_Flush(Tcl_Channel chan);
|
||||
EXTERN void Tcl_FreeResult(Tcl_Interp *interp);
|
||||
/* 148 */
|
||||
EXTERN int Tcl_GetAlias(Tcl_Interp *interp,
|
||||
const char *slaveCmd,
|
||||
const char *childCmd,
|
||||
Tcl_Interp **targetInterpPtr,
|
||||
CONST84 char **targetCmdPtr, int *argcPtr,
|
||||
CONST84 char ***argvPtr);
|
||||
/* 149 */
|
||||
EXTERN int Tcl_GetAliasObj(Tcl_Interp *interp,
|
||||
const char *slaveCmd,
|
||||
const char *childCmd,
|
||||
Tcl_Interp **targetInterpPtr,
|
||||
CONST84 char **targetCmdPtr, int *objcPtr,
|
||||
Tcl_Obj ***objv);
|
||||
@@ -504,7 +504,7 @@ EXTERN int Tcl_GetErrno(void);
|
||||
EXTERN CONST84_RETURN char * Tcl_GetHostName(void);
|
||||
/* 163 */
|
||||
EXTERN int Tcl_GetInterpPath(Tcl_Interp *interp,
|
||||
Tcl_Interp *slaveInterp);
|
||||
Tcl_Interp *childInterp);
|
||||
/* 164 */
|
||||
EXTERN Tcl_Interp * Tcl_GetMaster(Tcl_Interp *interp);
|
||||
/* 165 */
|
||||
@@ -532,8 +532,7 @@ EXTERN int Tcl_GetsObj(Tcl_Channel chan, Tcl_Obj *objPtr);
|
||||
/* 171 */
|
||||
EXTERN int Tcl_GetServiceMode(void);
|
||||
/* 172 */
|
||||
EXTERN Tcl_Interp * Tcl_GetSlave(Tcl_Interp *interp,
|
||||
const char *slaveName);
|
||||
EXTERN Tcl_Interp * Tcl_GetSlave(Tcl_Interp *interp, const char *name);
|
||||
/* 173 */
|
||||
EXTERN Tcl_Channel Tcl_GetStdChannel(int type);
|
||||
/* 174 */
|
||||
@@ -1949,8 +1948,8 @@ typedef struct TclStubs {
|
||||
char * (*tcl_Concat) (int argc, CONST84 char *const *argv); /* 83 */
|
||||
int (*tcl_ConvertElement) (const char *src, char *dst, int flags); /* 84 */
|
||||
int (*tcl_ConvertCountedElement) (const char *src, int length, char *dst, int flags); /* 85 */
|
||||
int (*tcl_CreateAlias) (Tcl_Interp *slave, const char *slaveCmd, Tcl_Interp *target, const char *targetCmd, int argc, CONST84 char *const *argv); /* 86 */
|
||||
int (*tcl_CreateAliasObj) (Tcl_Interp *slave, const char *slaveCmd, Tcl_Interp *target, const char *targetCmd, int objc, Tcl_Obj *const objv[]); /* 87 */
|
||||
int (*tcl_CreateAlias) (Tcl_Interp *child, const char *childCmd, Tcl_Interp *target, const char *targetCmd, int argc, CONST84 char *const *argv); /* 86 */
|
||||
int (*tcl_CreateAliasObj) (Tcl_Interp *child, const char *childCmd, Tcl_Interp *target, const char *targetCmd, int objc, Tcl_Obj *const objv[]); /* 87 */
|
||||
Tcl_Channel (*tcl_CreateChannel) (const Tcl_ChannelType *typePtr, const char *chanName, ClientData instanceData, int mask); /* 88 */
|
||||
void (*tcl_CreateChannelHandler) (Tcl_Channel chan, int mask, Tcl_ChannelProc *proc, ClientData clientData); /* 89 */
|
||||
void (*tcl_CreateCloseHandler) (Tcl_Channel chan, Tcl_CloseProc *proc, ClientData clientData); /* 90 */
|
||||
@@ -1960,7 +1959,7 @@ typedef struct TclStubs {
|
||||
Tcl_Interp * (*tcl_CreateInterp) (void); /* 94 */
|
||||
void (*tcl_CreateMathFunc) (Tcl_Interp *interp, const char *name, int numArgs, Tcl_ValueType *argTypes, Tcl_MathProc *proc, ClientData clientData); /* 95 */
|
||||
Tcl_Command (*tcl_CreateObjCommand) (Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc *proc, ClientData clientData, Tcl_CmdDeleteProc *deleteProc); /* 96 */
|
||||
Tcl_Interp * (*tcl_CreateSlave) (Tcl_Interp *interp, const char *slaveName, int isSafe); /* 97 */
|
||||
Tcl_Interp * (*tcl_CreateSlave) (Tcl_Interp *interp, const char *name, int isSafe); /* 97 */
|
||||
Tcl_TimerToken (*tcl_CreateTimerHandler) (int milliseconds, Tcl_TimerProc *proc, ClientData clientData); /* 98 */
|
||||
Tcl_Trace (*tcl_CreateTrace) (Tcl_Interp *interp, int level, Tcl_CmdTraceProc *proc, ClientData clientData); /* 99 */
|
||||
void (*tcl_DeleteAssocData) (Tcl_Interp *interp, const char *name); /* 100 */
|
||||
@@ -2011,8 +2010,8 @@ typedef struct TclStubs {
|
||||
Tcl_HashEntry * (*tcl_FirstHashEntry) (Tcl_HashTable *tablePtr, Tcl_HashSearch *searchPtr); /* 145 */
|
||||
int (*tcl_Flush) (Tcl_Channel chan); /* 146 */
|
||||
void (*tcl_FreeResult) (Tcl_Interp *interp); /* 147 */
|
||||
int (*tcl_GetAlias) (Tcl_Interp *interp, const char *slaveCmd, Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr, int *argcPtr, CONST84 char ***argvPtr); /* 148 */
|
||||
int (*tcl_GetAliasObj) (Tcl_Interp *interp, const char *slaveCmd, Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objv); /* 149 */
|
||||
int (*tcl_GetAlias) (Tcl_Interp *interp, const char *childCmd, Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr, int *argcPtr, CONST84 char ***argvPtr); /* 148 */
|
||||
int (*tcl_GetAliasObj) (Tcl_Interp *interp, const char *childCmd, Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objv); /* 149 */
|
||||
ClientData (*tcl_GetAssocData) (Tcl_Interp *interp, const char *name, Tcl_InterpDeleteProc **procPtr); /* 150 */
|
||||
Tcl_Channel (*tcl_GetChannel) (Tcl_Interp *interp, const char *chanName, int *modePtr); /* 151 */
|
||||
int (*tcl_GetChannelBufferSize) (Tcl_Channel chan); /* 152 */
|
||||
@@ -2026,7 +2025,7 @@ typedef struct TclStubs {
|
||||
CONST84_RETURN char * (*tcl_GetCommandName) (Tcl_Interp *interp, Tcl_Command command); /* 160 */
|
||||
int (*tcl_GetErrno) (void); /* 161 */
|
||||
CONST84_RETURN char * (*tcl_GetHostName) (void); /* 162 */
|
||||
int (*tcl_GetInterpPath) (Tcl_Interp *interp, Tcl_Interp *slaveInterp); /* 163 */
|
||||
int (*tcl_GetInterpPath) (Tcl_Interp *interp, Tcl_Interp *childInterp); /* 163 */
|
||||
Tcl_Interp * (*tcl_GetMaster) (Tcl_Interp *interp); /* 164 */
|
||||
const char * (*tcl_GetNameOfExecutable) (void); /* 165 */
|
||||
Tcl_Obj * (*tcl_GetObjResult) (Tcl_Interp *interp); /* 166 */
|
||||
@@ -2043,7 +2042,7 @@ typedef struct TclStubs {
|
||||
int (*tcl_Gets) (Tcl_Channel chan, Tcl_DString *dsPtr); /* 169 */
|
||||
int (*tcl_GetsObj) (Tcl_Channel chan, Tcl_Obj *objPtr); /* 170 */
|
||||
int (*tcl_GetServiceMode) (void); /* 171 */
|
||||
Tcl_Interp * (*tcl_GetSlave) (Tcl_Interp *interp, const char *slaveName); /* 172 */
|
||||
Tcl_Interp * (*tcl_GetSlave) (Tcl_Interp *interp, const char *name); /* 172 */
|
||||
Tcl_Channel (*tcl_GetStdChannel) (int type); /* 173 */
|
||||
CONST84_RETURN char * (*tcl_GetStringResult) (Tcl_Interp *interp); /* 174 */
|
||||
CONST84_RETURN char * (*tcl_GetVar) (Tcl_Interp *interp, const char *varName, int flags); /* 175 */
|
||||
|
||||
+2
-2
@@ -1043,7 +1043,7 @@ TclInitSubsystems(void)
|
||||
* implementation of self-initializing locks.
|
||||
*/
|
||||
|
||||
TclInitThreadStorage(); /* Creates master hash table for
|
||||
TclInitThreadStorage(); /* Creates main hash table for
|
||||
* thread local storage */
|
||||
#if USE_TCLALLOC
|
||||
TclInitAlloc(); /* Process wide mutex init */
|
||||
@@ -1157,7 +1157,7 @@ Tcl_Finalize(void)
|
||||
TclFinalizeFilesystem();
|
||||
|
||||
/*
|
||||
* Undo all Tcl_ObjType registrations, and reset the master list of free
|
||||
* Undo all Tcl_ObjType registrations, and reset the main list of free
|
||||
* Tcl_Obj's. After this returns, no more Tcl_Obj's should be allocated or
|
||||
* freed.
|
||||
*
|
||||
|
||||
+1
-1
@@ -4619,7 +4619,7 @@ Tcl_FSGetFileSystemForPath(
|
||||
/*
|
||||
* Check if the filesystem has changed in some way since this object's
|
||||
* internal representation was calculated. Before doing that, assure we
|
||||
* have the most up-to-date copy of the master filesystem. This is
|
||||
* have the most up-to-date copy of the main filesystem. This is
|
||||
* accomplished by the FsGetFirstFilesystem() call.
|
||||
*/
|
||||
|
||||
|
||||
+548
-548
File diff suppressed because it is too large
Load Diff
+5
-5
@@ -196,9 +196,9 @@ Tcl_LoadObjCmd(
|
||||
|
||||
target = interp;
|
||||
if (objc == 4) {
|
||||
const char *slaveIntName = Tcl_GetString(objv[3]);
|
||||
const char *childIntName = Tcl_GetString(objv[3]);
|
||||
|
||||
target = Tcl_GetSlave(interp, slaveIntName);
|
||||
target = Tcl_GetChild(interp, childIntName);
|
||||
if (target == NULL) {
|
||||
code = TCL_ERROR;
|
||||
goto done;
|
||||
@@ -619,9 +619,9 @@ Tcl_UnloadObjCmd(
|
||||
|
||||
target = interp;
|
||||
if (objc - i == 3) {
|
||||
const char *slaveIntName = Tcl_GetString(objv[i + 2]);
|
||||
const char *childIntName = Tcl_GetString(objv[i + 2]);
|
||||
|
||||
target = Tcl_GetSlave(interp, slaveIntName);
|
||||
target = Tcl_GetChild(interp, childIntName);
|
||||
if (target == NULL) {
|
||||
return TCL_ERROR;
|
||||
}
|
||||
@@ -1068,7 +1068,7 @@ TclGetLoadedPackages(
|
||||
* interpreter.
|
||||
*/
|
||||
|
||||
target = Tcl_GetSlave(interp, targetName);
|
||||
target = Tcl_GetChild(interp, targetName);
|
||||
if (target == NULL) {
|
||||
return TCL_ERROR;
|
||||
}
|
||||
|
||||
+1
-1
@@ -132,7 +132,7 @@ static const Tcl_MethodType classConstructor = {
|
||||
};
|
||||
|
||||
/*
|
||||
* Scripted parts of TclOO. First, the master script (cannot be outside this
|
||||
* Scripted parts of TclOO. First, the main script (cannot be outside this
|
||||
* file).
|
||||
*/
|
||||
|
||||
|
||||
+1
-1
@@ -110,7 +110,7 @@ TclOOInitInfo(
|
||||
TclMakeEnsemble(interp, "::oo::InfoClass", infoClassCmds);
|
||||
|
||||
/*
|
||||
* Install into the master [info] ensemble.
|
||||
* Install into the main [info] ensemble.
|
||||
*/
|
||||
|
||||
infoCmd = Tcl_FindCommand(interp, "info", NULL, TCL_GLOBAL_ONLY);
|
||||
|
||||
+2
-2
@@ -277,7 +277,7 @@ typedef struct Class {
|
||||
*/
|
||||
|
||||
typedef struct ThreadLocalData {
|
||||
int nsCount; /* Master epoch counter is used for keeping
|
||||
int nsCount; /* Main epoch counter is used for keeping
|
||||
* the values used in Tcl_Obj internal
|
||||
* representations sane. Must be thread-local
|
||||
* because Tcl_Objs can cross interpreter
|
||||
@@ -289,7 +289,7 @@ typedef struct Foundation {
|
||||
Tcl_Interp *interp;
|
||||
Class *objectCls; /* The root of the object system. */
|
||||
Class *classCls; /* The class of all classes. */
|
||||
Tcl_Namespace *ooNs; /* Master ::oo namespace. */
|
||||
Tcl_Namespace *ooNs; /* Main ::oo namespace. */
|
||||
Tcl_Namespace *defineNs; /* Namespace containing special commands for
|
||||
* manipulating objects and classes. The
|
||||
* "oo::define" command acts as a special kind
|
||||
|
||||
+1
-1
@@ -2172,7 +2172,7 @@ TclSubstTokens(
|
||||
* command, which is refered to by 'script'.
|
||||
* The 'clNextOuter' refers to the current
|
||||
* entry in the table of continuation lines in
|
||||
* this "master script", and the character
|
||||
* this "main script", and the character
|
||||
* offsets are relative to the 'outerScript'
|
||||
* as well.
|
||||
*
|
||||
|
||||
+9
-9
@@ -1506,15 +1506,15 @@ TestdelCmd(
|
||||
const char **argv) /* Argument strings. */
|
||||
{
|
||||
DelCmd *dPtr;
|
||||
Tcl_Interp *slave;
|
||||
Tcl_Interp *child;
|
||||
|
||||
if (argc != 4) {
|
||||
Tcl_SetResult(interp, "wrong # args", TCL_STATIC);
|
||||
return TCL_ERROR;
|
||||
}
|
||||
|
||||
slave = Tcl_GetSlave(interp, argv[1]);
|
||||
if (slave == NULL) {
|
||||
child = Tcl_GetChild(interp, argv[1]);
|
||||
if (child == NULL) {
|
||||
return TCL_ERROR;
|
||||
}
|
||||
|
||||
@@ -1523,7 +1523,7 @@ TestdelCmd(
|
||||
dPtr->deleteCmd = (char *)ckalloc(strlen(argv[3]) + 1);
|
||||
strcpy(dPtr->deleteCmd, argv[3]);
|
||||
|
||||
Tcl_CreateCommand(slave, argv[2], DelCmdProc, (ClientData) dPtr,
|
||||
Tcl_CreateCommand(child, argv[2], DelCmdProc, (ClientData) dPtr,
|
||||
DelDeleteProc);
|
||||
return TCL_OK;
|
||||
}
|
||||
@@ -2689,18 +2689,18 @@ TestinterpdeleteCmd(
|
||||
int argc, /* Number of arguments. */
|
||||
const char **argv) /* Argument strings. */
|
||||
{
|
||||
Tcl_Interp *slaveToDelete;
|
||||
Tcl_Interp *childToDelete;
|
||||
|
||||
if (argc != 2) {
|
||||
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
|
||||
" path\"", NULL);
|
||||
return TCL_ERROR;
|
||||
}
|
||||
slaveToDelete = Tcl_GetSlave(interp, argv[1]);
|
||||
if (slaveToDelete == NULL) {
|
||||
childToDelete = Tcl_GetChild(interp, argv[1]);
|
||||
if (childToDelete == NULL) {
|
||||
return TCL_ERROR;
|
||||
}
|
||||
Tcl_DeleteInterp(slaveToDelete);
|
||||
Tcl_DeleteInterp(childToDelete);
|
||||
return TCL_OK;
|
||||
}
|
||||
|
||||
@@ -7731,7 +7731,7 @@ TestInterpResolverCmd(
|
||||
return TCL_ERROR;
|
||||
}
|
||||
if (objc == 3) {
|
||||
interp = Tcl_GetSlave(interp, Tcl_GetString(objv[2]));
|
||||
interp = Tcl_GetChild(interp, Tcl_GetString(objv[2]));
|
||||
if (interp == NULL) {
|
||||
Tcl_AppendResult(interp, "provided interpreter not found", NULL);
|
||||
return TCL_ERROR;
|
||||
|
||||
+1
-1
@@ -377,7 +377,7 @@ proc auto_mkindex_parser::mkindex {file} {
|
||||
# auto_mkindex_parser::hook command
|
||||
#
|
||||
# Registers a Tcl command to evaluate when initializing the slave interpreter
|
||||
# used by the mkindex parser. The command is evaluated in the master
|
||||
# used by the mkindex parser. The command is evaluated in the parent
|
||||
# interpreter, and can use the variable auto_mkindex_parser::parser to get to
|
||||
# the slave
|
||||
|
||||
|
||||
+2
-2
@@ -3304,7 +3304,7 @@ proc ::tcl::clock::LoadTimeZoneFile { fileName } {
|
||||
return
|
||||
}
|
||||
|
||||
# Since an unsafe interp uses the [clock] command in the master, this code
|
||||
# Since an unsafe interp uses the [clock] command in the parent, this code
|
||||
# is security sensitive. Make sure that the path name cannot escape the
|
||||
# given directory.
|
||||
|
||||
@@ -3344,7 +3344,7 @@ proc ::tcl::clock::LoadTimeZoneFile { fileName } {
|
||||
proc ::tcl::clock::LoadZoneinfoFile { fileName } {
|
||||
variable ZoneinfoPaths
|
||||
|
||||
# Since an unsafe interp uses the [clock] command in the master, this code
|
||||
# Since an unsafe interp uses the [clock] command in the parent, this code
|
||||
# is security sensitive. Make sure that the path name cannot escape the
|
||||
# given directory.
|
||||
|
||||
|
||||
@@ -44,8 +44,8 @@ namespace eval ::tcl {
|
||||
{-intflag 7}
|
||||
{-weirdflag "help string"}
|
||||
{-noStatics "Not ok to load static packages"}
|
||||
{-nestedloading1 true "OK to load into nested slaves"}
|
||||
{-nestedloading2 -boolean true "OK to load into nested slaves"}
|
||||
{-nestedloading1 true "OK to load into nested children"}
|
||||
{-nestedloading2 -boolean true "OK to load into nested children"}
|
||||
{-libsOK -choice {Tk SybTcl}
|
||||
"List of packages that can be loaded"}
|
||||
{-precision -int 12 "Number of digits of precision"}
|
||||
|
||||
+1
-1
@@ -237,7 +237,7 @@ proc pkg_mkIndex {args} {
|
||||
$c eval [list set ::tcl::file $file]
|
||||
$c eval [list set ::tcl::direct $direct]
|
||||
|
||||
# Download needed procedures into the slave because we've just deleted
|
||||
# Download needed procedures into the child because we've just deleted
|
||||
# the unknown procedure. This doesn't handle procedures with default
|
||||
# arguments.
|
||||
|
||||
|
||||
+189
-189
@@ -1,9 +1,9 @@
|
||||
# safe.tcl --
|
||||
#
|
||||
# This file provide a safe loading/sourcing mechanism for safe interpreters.
|
||||
# It implements a virtual path mecanism to hide the real pathnames from the
|
||||
# slave. It runs in a master interpreter and sets up data structure and
|
||||
# aliases that will be invoked when used from a slave interpreter.
|
||||
# It implements a virtual path mechanism to hide the real pathnames from the
|
||||
# child. It runs in a parent interpreter and sets up data structure and
|
||||
# aliases that will be invoked when used from a child interpreter.
|
||||
#
|
||||
# See the safe.n man page for details.
|
||||
#
|
||||
@@ -79,25 +79,25 @@ proc ::safe::InterpNested {} {
|
||||
# Interface/entry point function and front end for "Create"
|
||||
proc ::safe::interpCreate {args} {
|
||||
set Args [::tcl::OptKeyParse ::safe::interpCreate $args]
|
||||
InterpCreate $slave $accessPath \
|
||||
InterpCreate $child $accessPath \
|
||||
[InterpStatics] [InterpNested] $deleteHook
|
||||
}
|
||||
|
||||
proc ::safe::interpInit {args} {
|
||||
set Args [::tcl::OptKeyParse ::safe::interpIC $args]
|
||||
if {![::interp exists $slave]} {
|
||||
return -code error "\"$slave\" is not an interpreter"
|
||||
if {![::interp exists $child]} {
|
||||
return -code error "\"$child\" is not an interpreter"
|
||||
}
|
||||
InterpInit $slave $accessPath \
|
||||
InterpInit $child $accessPath \
|
||||
[InterpStatics] [InterpNested] $deleteHook
|
||||
}
|
||||
|
||||
# Check that the given slave is "one of us"
|
||||
proc ::safe::CheckInterp {slave} {
|
||||
namespace upvar ::safe S$slave state
|
||||
if {![info exists state] || ![::interp exists $slave]} {
|
||||
# Check that the given child is "one of us"
|
||||
proc ::safe::CheckInterp {child} {
|
||||
namespace upvar ::safe S$child state
|
||||
if {![info exists state] || ![::interp exists $child]} {
|
||||
return -code error \
|
||||
"\"$slave\" is not an interpreter managed by ::safe::"
|
||||
"\"$child\" is not an interpreter managed by ::safe::"
|
||||
}
|
||||
}
|
||||
|
||||
@@ -119,11 +119,11 @@ proc ::safe::interpConfigure {args} {
|
||||
1 {
|
||||
# If we have exactly 1 argument the semantic is to return all
|
||||
# the current configuration. We still call OptKeyParse though
|
||||
# we know that "slave" is our given argument because it also
|
||||
# we know that "child" is our given argument because it also
|
||||
# checks for the "-help" option.
|
||||
set Args [::tcl::OptKeyParse ::safe::interpIC $args]
|
||||
CheckInterp $slave
|
||||
namespace upvar ::safe S$slave state
|
||||
CheckInterp $child
|
||||
namespace upvar ::safe S$child state
|
||||
|
||||
return [join [list \
|
||||
[list -accessPath $state(access_path)] \
|
||||
@@ -134,7 +134,7 @@ proc ::safe::interpConfigure {args} {
|
||||
2 {
|
||||
# If we have exactly 2 arguments the semantic is a "configure
|
||||
# get"
|
||||
lassign $args slave arg
|
||||
lassign $args child arg
|
||||
|
||||
# get the flag sub program (we 'know' about Opt's internal
|
||||
# representation of data)
|
||||
@@ -145,8 +145,8 @@ proc ::safe::interpConfigure {args} {
|
||||
} elseif {$hits == 0} {
|
||||
return -code error [::tcl::OptFlagUsage $desc $arg]
|
||||
}
|
||||
CheckInterp $slave
|
||||
namespace upvar ::safe S$slave state
|
||||
CheckInterp $child
|
||||
namespace upvar ::safe S$child state
|
||||
|
||||
set item [::tcl::OptCurDesc $desc]
|
||||
set name [::tcl::OptName $item]
|
||||
@@ -186,8 +186,8 @@ proc ::safe::interpConfigure {args} {
|
||||
# Otherwise we want to parse the arguments like init and
|
||||
# create did
|
||||
set Args [::tcl::OptKeyParse ::safe::interpIC $args]
|
||||
CheckInterp $slave
|
||||
namespace upvar ::safe S$slave state
|
||||
CheckInterp $child
|
||||
namespace upvar ::safe S$child state
|
||||
|
||||
# Get the current (and not the default) values of whatever has
|
||||
# not been given:
|
||||
@@ -217,13 +217,13 @@ proc ::safe::interpConfigure {args} {
|
||||
set deleteHook $state(cleanupHook)
|
||||
}
|
||||
# we can now reconfigure :
|
||||
InterpSetConfig $slave $accessPath $statics $nested $deleteHook
|
||||
# auto_reset the slave (to completly synch the new access_path)
|
||||
InterpSetConfig $child $accessPath $statics $nested $deleteHook
|
||||
# auto_reset the child (to completly synch the new access_path)
|
||||
if {$doreset} {
|
||||
if {[catch {::interp eval $slave {auto_reset}} msg]} {
|
||||
Log $slave "auto_reset failed: $msg"
|
||||
if {[catch {::interp eval $child {auto_reset}} msg]} {
|
||||
Log $child "auto_reset failed: $msg"
|
||||
} else {
|
||||
Log $slave "successful auto_reset" NOTICE
|
||||
Log $child "successful auto_reset" NOTICE
|
||||
}
|
||||
}
|
||||
}
|
||||
@@ -239,17 +239,17 @@ proc ::safe::interpConfigure {args} {
|
||||
#
|
||||
# safe::InterpCreate : doing the real job
|
||||
#
|
||||
# This procedure creates a safe slave and initializes it with the safe
|
||||
# This procedure creates a safe child and initializes it with the safe
|
||||
# base aliases.
|
||||
# NB: slave name must be simple alphanumeric string, no spaces, no (), no
|
||||
# NB: child name must be simple alphanumeric string, no spaces, no (), no
|
||||
# {},... {because the state array is stored as part of the name}
|
||||
#
|
||||
# Returns the slave name.
|
||||
# Returns the child name.
|
||||
#
|
||||
# Optional Arguments :
|
||||
# + slave name : if empty, generated name will be used
|
||||
# + child name : if empty, generated name will be used
|
||||
# + access_path: path list controlling where load/source can occur,
|
||||
# if empty: the master auto_path will be used.
|
||||
# if empty: the parent auto_path will be used.
|
||||
# + staticsok : flag, if 0 :no static package can be loaded (load {} Xxx)
|
||||
# if 1 :static packages are ok.
|
||||
# + nestedok: flag, if 0 :no loading to sub-sub interps (load xx xx sub)
|
||||
@@ -257,35 +257,35 @@ proc ::safe::interpConfigure {args} {
|
||||
|
||||
# use the full name and no indent so auto_mkIndex can find us
|
||||
proc ::safe::InterpCreate {
|
||||
slave
|
||||
child
|
||||
access_path
|
||||
staticsok
|
||||
nestedok
|
||||
deletehook
|
||||
} {
|
||||
# Create the slave.
|
||||
if {$slave ne ""} {
|
||||
::interp create -safe $slave
|
||||
# Create the child.
|
||||
if {$child ne ""} {
|
||||
::interp create -safe $child
|
||||
} else {
|
||||
# empty argument: generate slave name
|
||||
set slave [::interp create -safe]
|
||||
# empty argument: generate child name
|
||||
set child [::interp create -safe]
|
||||
}
|
||||
Log $slave "Created" NOTICE
|
||||
Log $child "Created" NOTICE
|
||||
|
||||
# Initialize it. (returns slave name)
|
||||
InterpInit $slave $access_path $staticsok $nestedok $deletehook
|
||||
# Initialize it. (returns child name)
|
||||
InterpInit $child $access_path $staticsok $nestedok $deletehook
|
||||
}
|
||||
|
||||
#
|
||||
# InterpSetConfig (was setAccessPath) :
|
||||
# Sets up slave virtual auto_path and corresponding structure within
|
||||
# the master. Also sets the tcl_library in the slave to be the first
|
||||
# Sets up child virtual auto_path and corresponding structure within
|
||||
# the parent. Also sets the tcl_library in the child to be the first
|
||||
# directory in the path.
|
||||
# NB: If you change the path after the slave has been initialized you
|
||||
# probably need to call "auto_reset" in the slave in order that it gets
|
||||
# NB: If you change the path after the child has been initialized you
|
||||
# probably need to call "auto_reset" in the child in order that it gets
|
||||
# the right auto_index() array values.
|
||||
|
||||
proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook} {
|
||||
proc ::safe::InterpSetConfig {child access_path staticsok nestedok deletehook} {
|
||||
global auto_path
|
||||
|
||||
# determine and store the access path if empty
|
||||
@@ -298,45 +298,45 @@ proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook} {
|
||||
if {$where == -1} {
|
||||
# not found, add it.
|
||||
set access_path [linsert $access_path 0 [info library]]
|
||||
Log $slave "tcl_library was not in auto_path,\
|
||||
added it to slave's access_path" NOTICE
|
||||
Log $child "tcl_library was not in auto_path,\
|
||||
added it to child's access_path" NOTICE
|
||||
} elseif {$where != 0} {
|
||||
# not first, move it first
|
||||
set access_path [linsert \
|
||||
[lreplace $access_path $where $where] \
|
||||
0 [info library]]
|
||||
Log $slave "tcl_libray was not in first in auto_path,\
|
||||
moved it to front of slave's access_path" NOTICE
|
||||
Log $child "tcl_libray was not in first in auto_path,\
|
||||
moved it to front of child's access_path" NOTICE
|
||||
}
|
||||
|
||||
# Add 1st level sub dirs (will searched by auto loading from tcl
|
||||
# code in the slave using glob and thus fail, so we add them here
|
||||
# code in the child using glob and thus fail, so we add them here
|
||||
# so by default it works the same).
|
||||
set access_path [AddSubDirs $access_path]
|
||||
}
|
||||
|
||||
Log $slave "Setting accessPath=($access_path) staticsok=$staticsok\
|
||||
Log $child "Setting accessPath=($access_path) staticsok=$staticsok\
|
||||
nestedok=$nestedok deletehook=($deletehook)" NOTICE
|
||||
|
||||
namespace upvar ::safe S$slave state
|
||||
namespace upvar ::safe S$child state
|
||||
|
||||
# clear old autopath if it existed
|
||||
# build new one
|
||||
# Extend the access list with the paths used to look for Tcl Modules.
|
||||
# We save the virtual form separately as well, as syncing it with the
|
||||
# slave has to be defered until the necessary commands are present for
|
||||
# child has to be defered until the necessary commands are present for
|
||||
# setup.
|
||||
|
||||
set norm_access_path {}
|
||||
set slave_access_path {}
|
||||
set child_access_path {}
|
||||
set map_access_path {}
|
||||
set remap_access_path {}
|
||||
set slave_tm_path {}
|
||||
set child_tm_path {}
|
||||
|
||||
set i 0
|
||||
foreach dir $access_path {
|
||||
set token [PathToken $i]
|
||||
lappend slave_access_path $token
|
||||
lappend child_access_path $token
|
||||
lappend map_access_path $token $dir
|
||||
lappend remap_access_path $dir $token
|
||||
lappend norm_access_path [file normalize $dir]
|
||||
@@ -357,11 +357,11 @@ proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook} {
|
||||
|
||||
set token [PathToken $i]
|
||||
lappend access_path $dir
|
||||
lappend slave_access_path $token
|
||||
lappend child_access_path $token
|
||||
lappend map_access_path $token $dir
|
||||
lappend remap_access_path $dir $token
|
||||
lappend norm_access_path [file normalize $dir]
|
||||
lappend slave_tm_path $token
|
||||
lappend child_tm_path $token
|
||||
incr i
|
||||
|
||||
# [Bug 2854929]
|
||||
@@ -378,13 +378,13 @@ proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook} {
|
||||
set state(access_path,map) $map_access_path
|
||||
set state(access_path,remap) $remap_access_path
|
||||
set state(access_path,norm) $norm_access_path
|
||||
set state(access_path,slave) $slave_access_path
|
||||
set state(tm_path_slave) $slave_tm_path
|
||||
set state(access_path,child) $child_access_path
|
||||
set state(tm_path_child) $child_tm_path
|
||||
set state(staticsok) $staticsok
|
||||
set state(nestedok) $nestedok
|
||||
set state(cleanupHook) $deletehook
|
||||
|
||||
SyncAccessPath $slave
|
||||
SyncAccessPath $child
|
||||
}
|
||||
|
||||
#
|
||||
@@ -392,8 +392,8 @@ proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook} {
|
||||
# FindInAccessPath:
|
||||
# Search for a real directory and returns its virtual Id (including the
|
||||
# "$")
|
||||
proc ::safe::interpFindInAccessPath {slave path} {
|
||||
namespace upvar ::safe S$slave state
|
||||
proc ::safe::interpFindInAccessPath {child path} {
|
||||
namespace upvar ::safe S$child state
|
||||
|
||||
if {![dict exists $state(access_path,remap) $path]} {
|
||||
return -code error "$path not found in access path $access_path"
|
||||
@@ -406,10 +406,10 @@ proc ::safe::interpFindInAccessPath {slave path} {
|
||||
# addToAccessPath:
|
||||
# add (if needed) a real directory to access path and return its
|
||||
# virtual token (including the "$").
|
||||
proc ::safe::interpAddToAccessPath {slave path} {
|
||||
proc ::safe::interpAddToAccessPath {child path} {
|
||||
# first check if the directory is already in there
|
||||
# (inlined interpFindInAccessPath).
|
||||
namespace upvar ::safe S$slave state
|
||||
namespace upvar ::safe S$child state
|
||||
|
||||
if {[dict exists $state(access_path,remap) $path]} {
|
||||
return [dict get $state(access_path,remap) $path]
|
||||
@@ -419,12 +419,12 @@ proc ::safe::interpAddToAccessPath {slave path} {
|
||||
set token [PathToken [llength $state(access_path)]]
|
||||
|
||||
lappend state(access_path) $path
|
||||
lappend state(access_path,slave) $token
|
||||
lappend state(access_path,child) $token
|
||||
lappend state(access_path,map) $token $path
|
||||
lappend state(access_path,remap) $path $token
|
||||
lappend state(access_path,norm) [file normalize $path]
|
||||
|
||||
SyncAccessPath $slave
|
||||
SyncAccessPath $child
|
||||
return $token
|
||||
}
|
||||
|
||||
@@ -432,25 +432,25 @@ proc ::safe::interpAddToAccessPath {slave path} {
|
||||
# interpreter. It is useful when you want to install the safe base aliases
|
||||
# into a preexisting safe interpreter.
|
||||
proc ::safe::InterpInit {
|
||||
slave
|
||||
child
|
||||
access_path
|
||||
staticsok
|
||||
nestedok
|
||||
deletehook
|
||||
} {
|
||||
# Configure will generate an access_path when access_path is empty.
|
||||
InterpSetConfig $slave $access_path $staticsok $nestedok $deletehook
|
||||
InterpSetConfig $child $access_path $staticsok $nestedok $deletehook
|
||||
|
||||
# NB we need to add [namespace current], aliases are always absolute
|
||||
# paths.
|
||||
|
||||
# These aliases let the slave load files to define new commands
|
||||
# This alias lets the slave use the encoding names, convertfrom,
|
||||
# These aliases let the child load files to define new commands
|
||||
# This alias lets the child use the encoding names, convertfrom,
|
||||
# convertto, and system, but not "encoding system <name>" to set the
|
||||
# system encoding.
|
||||
# Handling Tcl Modules, we need a restricted form of Glob.
|
||||
# This alias interposes on the 'exit' command and cleanly terminates
|
||||
# the slave.
|
||||
# the child.
|
||||
|
||||
foreach {command alias} {
|
||||
source AliasSource
|
||||
@@ -459,61 +459,61 @@ proc ::safe::InterpInit {
|
||||
exit interpDelete
|
||||
glob AliasGlob
|
||||
} {
|
||||
::interp alias $slave $command {} [namespace current]::$alias $slave
|
||||
::interp alias $child $command {} [namespace current]::$alias $child
|
||||
}
|
||||
|
||||
# This alias lets the slave have access to a subset of the 'file'
|
||||
# This alias lets the child have access to a subset of the 'file'
|
||||
# command functionality.
|
||||
|
||||
::interp expose $slave file
|
||||
::interp expose $child file
|
||||
foreach subcommand {dirname extension rootname tail} {
|
||||
::interp alias $slave ::tcl::file::$subcommand {} \
|
||||
::safe::AliasFileSubcommand $slave $subcommand
|
||||
::interp alias $child ::tcl::file::$subcommand {} \
|
||||
::safe::AliasFileSubcommand $child $subcommand
|
||||
}
|
||||
foreach subcommand {
|
||||
atime attributes copy delete executable exists isdirectory isfile
|
||||
link lstat mtime mkdir nativename normalize owned readable readlink
|
||||
rename size stat tempfile type volumes writable
|
||||
} {
|
||||
::interp alias $slave ::tcl::file::$subcommand {} \
|
||||
::safe::BadSubcommand $slave file $subcommand
|
||||
::interp alias $child ::tcl::file::$subcommand {} \
|
||||
::safe::BadSubcommand $child file $subcommand
|
||||
}
|
||||
|
||||
# Subcommands of info
|
||||
foreach {subcommand alias} {
|
||||
nameofexecutable AliasExeName
|
||||
} {
|
||||
::interp alias $slave ::tcl::info::$subcommand \
|
||||
{} [namespace current]::$alias $slave
|
||||
::interp alias $child ::tcl::info::$subcommand \
|
||||
{} [namespace current]::$alias $child
|
||||
}
|
||||
|
||||
# The allowed slave variables already have been set by Tcl_MakeSafe(3)
|
||||
# The allowed child variables already have been set by Tcl_MakeSafe(3)
|
||||
|
||||
# Source init.tcl and tm.tcl into the slave, to get auto_load and
|
||||
# Source init.tcl and tm.tcl into the child, to get auto_load and
|
||||
# other procedures defined:
|
||||
|
||||
if {[catch {::interp eval $slave {
|
||||
if {[catch {::interp eval $child {
|
||||
source [file join $tcl_library init.tcl]
|
||||
}} msg opt]} {
|
||||
Log $slave "can't source init.tcl ($msg)"
|
||||
return -options $opt "can't source init.tcl into slave $slave ($msg)"
|
||||
Log $child "can't source init.tcl ($msg)"
|
||||
return -options $opt "can't source init.tcl into child $child ($msg)"
|
||||
}
|
||||
|
||||
if {[catch {::interp eval $slave {
|
||||
if {[catch {::interp eval $child {
|
||||
source [file join $tcl_library tm.tcl]
|
||||
}} msg opt]} {
|
||||
Log $slave "can't source tm.tcl ($msg)"
|
||||
return -options $opt "can't source tm.tcl into slave $slave ($msg)"
|
||||
Log $child "can't source tm.tcl ($msg)"
|
||||
return -options $opt "can't source tm.tcl into child $child ($msg)"
|
||||
}
|
||||
|
||||
# Sync the paths used to search for Tcl modules. This can be done only
|
||||
# now, after tm.tcl was loaded.
|
||||
namespace upvar ::safe S$slave state
|
||||
if {[llength $state(tm_path_slave)] > 0} {
|
||||
::interp eval $slave [list \
|
||||
::tcl::tm::add {*}[lreverse $state(tm_path_slave)]]
|
||||
namespace upvar ::safe S$child state
|
||||
if {[llength $state(tm_path_child)] > 0} {
|
||||
::interp eval $child [list \
|
||||
::tcl::tm::add {*}[lreverse $state(tm_path_child)]]
|
||||
}
|
||||
return $slave
|
||||
return $child
|
||||
}
|
||||
|
||||
# Add (only if needed, avoid duplicates) 1 level of sub directories to an
|
||||
@@ -539,15 +539,15 @@ proc ::safe::AddSubDirs {pathList} {
|
||||
return $res
|
||||
}
|
||||
|
||||
# This procedure deletes a safe slave managed by Safe Tcl and cleans up
|
||||
# This procedure deletes a safe child managed by Safe Tcl and cleans up
|
||||
# associated state:
|
||||
|
||||
proc ::safe::interpDelete {slave} {
|
||||
Log $slave "About to delete" NOTICE
|
||||
proc ::safe::interpDelete {child} {
|
||||
Log $child "About to delete" NOTICE
|
||||
|
||||
namespace upvar ::safe S$slave state
|
||||
namespace upvar ::safe S$child state
|
||||
|
||||
# If the slave has a cleanup hook registered, call it. Check the
|
||||
# If the child has a cleanup hook registered, call it. Check the
|
||||
# existance because we might be called to delete an interp which has
|
||||
# not been registered with us at all
|
||||
|
||||
@@ -558,14 +558,14 @@ proc ::safe::interpDelete {slave} {
|
||||
# we'll loop
|
||||
unset state(cleanupHook)
|
||||
try {
|
||||
{*}$hook $slave
|
||||
{*}$hook $child
|
||||
} on error err {
|
||||
Log $slave "Delete hook error ($err)"
|
||||
Log $child "Delete hook error ($err)"
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# Discard the global array of state associated with the slave, and
|
||||
# Discard the global array of state associated with the child, and
|
||||
# delete the interpreter.
|
||||
|
||||
if {[info exists state]} {
|
||||
@@ -574,9 +574,9 @@ proc ::safe::interpDelete {slave} {
|
||||
|
||||
# if we have been called twice, the interp might have been deleted
|
||||
# already
|
||||
if {[::interp exists $slave]} {
|
||||
::interp delete $slave
|
||||
Log $slave "Deleted" NOTICE
|
||||
if {[::interp exists $child]} {
|
||||
::interp delete $child
|
||||
Log $child "Deleted" NOTICE
|
||||
}
|
||||
|
||||
return
|
||||
@@ -602,9 +602,9 @@ proc ::safe::setLogCmd {args} {
|
||||
} else {
|
||||
# Activate logging, define proper command.
|
||||
|
||||
proc ::safe::Log {slave msg {type ERROR}} {
|
||||
proc ::safe::Log {child msg {type ERROR}} {
|
||||
variable Log
|
||||
{*}$Log "$type for slave $slave : $msg"
|
||||
{*}$Log "$type for child $child : $msg"
|
||||
return
|
||||
}
|
||||
}
|
||||
@@ -613,24 +613,24 @@ proc ::safe::setLogCmd {args} {
|
||||
# ------------------- END OF PUBLIC METHODS ------------
|
||||
|
||||
#
|
||||
# Sets the slave auto_path to the master recorded value. Also sets
|
||||
# Sets the child auto_path to the parent recorded value. Also sets
|
||||
# tcl_library to the first token of the virtual path.
|
||||
#
|
||||
proc ::safe::SyncAccessPath {slave} {
|
||||
namespace upvar ::safe S$slave state
|
||||
proc ::safe::SyncAccessPath {child} {
|
||||
namespace upvar ::safe S$child state
|
||||
|
||||
set slave_access_path $state(access_path,slave)
|
||||
::interp eval $slave [list set auto_path $slave_access_path]
|
||||
set child_access_path $state(access_path,child)
|
||||
::interp eval $child [list set auto_path $child_access_path]
|
||||
|
||||
Log $slave "auto_path in $slave has been set to $slave_access_path"\
|
||||
Log $child "auto_path in $child has been set to $child_access_path"\
|
||||
NOTICE
|
||||
|
||||
# This code assumes that info library is the first element in the
|
||||
# list of auto_path's. See -> InterpSetConfig for the code which
|
||||
# ensures this condition.
|
||||
|
||||
::interp eval $slave [list \
|
||||
set tcl_library [lindex $slave_access_path 0]]
|
||||
::interp eval $child [list \
|
||||
set tcl_library [lindex $child_access_path 0]]
|
||||
}
|
||||
|
||||
# Returns the virtual token for directory number N.
|
||||
@@ -643,8 +643,8 @@ proc ::safe::PathToken {n} {
|
||||
#
|
||||
# translate virtual path into real path
|
||||
#
|
||||
proc ::safe::TranslatePath {slave path} {
|
||||
namespace upvar ::safe S$slave state
|
||||
proc ::safe::TranslatePath {child path} {
|
||||
namespace upvar ::safe S$child state
|
||||
|
||||
# somehow strip the namespaces 'functionality' out (the danger is that
|
||||
# we would strip valid macintosh "../" queries... :
|
||||
@@ -659,7 +659,7 @@ proc ::safe::TranslatePath {slave path} {
|
||||
|
||||
# file name control (limit access to files/resources that should be a
|
||||
# valid tcl source file)
|
||||
proc ::safe::CheckFileName {slave file} {
|
||||
proc ::safe::CheckFileName {child file} {
|
||||
# This used to limit what can be sourced to ".tcl" and forbid files
|
||||
# with more than 1 dot and longer than 14 chars, but I changed that
|
||||
# for 8.4 as a safe interp has enough internal protection already to
|
||||
@@ -680,17 +680,17 @@ proc ::safe::CheckFileName {slave file} {
|
||||
# interpreters that are *almost* safe. In particular, it just acts to
|
||||
# prevent discovery of what home directories exist.
|
||||
|
||||
proc ::safe::AliasFileSubcommand {slave subcommand name} {
|
||||
proc ::safe::AliasFileSubcommand {child subcommand name} {
|
||||
if {[string match ~* $name]} {
|
||||
set name ./$name
|
||||
}
|
||||
tailcall ::interp invokehidden $slave tcl:file:$subcommand $name
|
||||
tailcall ::interp invokehidden $child tcl:file:$subcommand $name
|
||||
}
|
||||
|
||||
# AliasGlob is the target of the "glob" alias in safe interpreters.
|
||||
|
||||
proc ::safe::AliasGlob {slave args} {
|
||||
Log $slave "GLOB ! $args" NOTICE
|
||||
proc ::safe::AliasGlob {child args} {
|
||||
Log $child "GLOB ! $args" NOTICE
|
||||
set cmd {}
|
||||
set at 0
|
||||
array set got {
|
||||
@@ -738,7 +738,7 @@ proc ::safe::AliasGlob {slave args} {
|
||||
return -code error "unknown command glob"
|
||||
}
|
||||
-* {
|
||||
Log $slave "Safe base rejecting glob option '$opt'"
|
||||
Log $child "Safe base rejecting glob option '$opt'"
|
||||
return -code error "Safe base rejecting glob option '$opt'"
|
||||
}
|
||||
default {
|
||||
@@ -749,14 +749,14 @@ proc ::safe::AliasGlob {slave args} {
|
||||
}
|
||||
|
||||
# Get the real path from the virtual one and check that the path is in the
|
||||
# access path of that slave. Done after basic argument processing so that
|
||||
# access path of that child. Done after basic argument processing so that
|
||||
# we know if -nocomplain is set.
|
||||
if {$got(-directory)} {
|
||||
try {
|
||||
set dir [TranslatePath $slave $virtualdir]
|
||||
DirInAccessPath $slave $dir
|
||||
set dir [TranslatePath $child $virtualdir]
|
||||
DirInAccessPath $child $dir
|
||||
} on error msg {
|
||||
Log $slave $msg
|
||||
Log $child $msg
|
||||
if {$got(-nocomplain)} return
|
||||
return -code error "permission denied"
|
||||
}
|
||||
@@ -779,11 +779,11 @@ proc ::safe::AliasGlob {slave args} {
|
||||
if {$thedir eq "*" &&
|
||||
($thefile eq "pkgIndex.tcl" || $thefile eq "*.tm")} {
|
||||
set mapped 0
|
||||
foreach d [glob -directory [TranslatePath $slave $virtualdir] \
|
||||
foreach d [glob -directory [TranslatePath $child $virtualdir] \
|
||||
-types d -tails *] {
|
||||
catch {
|
||||
DirInAccessPath $slave \
|
||||
[TranslatePath $slave [file join $virtualdir $d]]
|
||||
DirInAccessPath $child \
|
||||
[TranslatePath $child [file join $virtualdir $d]]
|
||||
lappend cmd [file join $d $thefile]
|
||||
set mapped 1
|
||||
}
|
||||
@@ -791,31 +791,31 @@ proc ::safe::AliasGlob {slave args} {
|
||||
if {$mapped} continue
|
||||
}
|
||||
try {
|
||||
DirInAccessPath $slave [TranslatePath $slave \
|
||||
DirInAccessPath $child [TranslatePath $child \
|
||||
[file join $virtualdir $thedir]]
|
||||
} on error msg {
|
||||
Log $slave $msg
|
||||
Log $child $msg
|
||||
if {$got(-nocomplain)} continue
|
||||
return -code error "permission denied"
|
||||
}
|
||||
lappend cmd $opt
|
||||
}
|
||||
|
||||
Log $slave "GLOB = $cmd" NOTICE
|
||||
Log $child "GLOB = $cmd" NOTICE
|
||||
|
||||
if {$got(-nocomplain) && [llength $cmd] eq $firstPattern} {
|
||||
return
|
||||
}
|
||||
try {
|
||||
set entries [::interp invokehidden $slave glob {*}$cmd]
|
||||
set entries [::interp invokehidden $child glob {*}$cmd]
|
||||
} on error msg {
|
||||
Log $slave $msg
|
||||
Log $child $msg
|
||||
return -code error "script error"
|
||||
}
|
||||
|
||||
Log $slave "GLOB < $entries" NOTICE
|
||||
Log $child "GLOB < $entries" NOTICE
|
||||
|
||||
# Translate path back to what the slave should see.
|
||||
# Translate path back to what the child should see.
|
||||
set res {}
|
||||
set l [string length $dir]
|
||||
foreach p $entries {
|
||||
@@ -825,13 +825,13 @@ proc ::safe::AliasGlob {slave args} {
|
||||
lappend res $p
|
||||
}
|
||||
|
||||
Log $slave "GLOB > $res" NOTICE
|
||||
Log $child "GLOB > $res" NOTICE
|
||||
return $res
|
||||
}
|
||||
|
||||
# AliasSource is the target of the "source" alias in safe interpreters.
|
||||
|
||||
proc ::safe::AliasSource {slave args} {
|
||||
proc ::safe::AliasSource {child args} {
|
||||
set argc [llength $args]
|
||||
# Extended for handling of Tcl Modules to allow not only "source
|
||||
# filename", but "source -encoding E filename" as well.
|
||||
@@ -840,7 +840,7 @@ proc ::safe::AliasSource {slave args} {
|
||||
set encoding [lindex $args 1]
|
||||
set at 2
|
||||
if {$encoding eq "identity"} {
|
||||
Log $slave "attempt to use the identity encoding"
|
||||
Log $child "attempt to use the identity encoding"
|
||||
return -code error "permission denied"
|
||||
}
|
||||
} else {
|
||||
@@ -849,39 +849,39 @@ proc ::safe::AliasSource {slave args} {
|
||||
}
|
||||
if {$argc != 1} {
|
||||
set msg "wrong # args: should be \"source ?-encoding E? fileName\""
|
||||
Log $slave "$msg ($args)"
|
||||
Log $child "$msg ($args)"
|
||||
return -code error $msg
|
||||
}
|
||||
set file [lindex $args $at]
|
||||
|
||||
# get the real path from the virtual one.
|
||||
if {[catch {
|
||||
set realfile [TranslatePath $slave $file]
|
||||
set realfile [TranslatePath $child $file]
|
||||
} msg]} {
|
||||
Log $slave $msg
|
||||
Log $child $msg
|
||||
return -code error "permission denied"
|
||||
}
|
||||
|
||||
# check that the path is in the access path of that slave
|
||||
# check that the path is in the access path of that child
|
||||
if {[catch {
|
||||
FileInAccessPath $slave $realfile
|
||||
FileInAccessPath $child $realfile
|
||||
} msg]} {
|
||||
Log $slave $msg
|
||||
Log $child $msg
|
||||
return -code error "permission denied"
|
||||
}
|
||||
|
||||
# do the checks on the filename :
|
||||
if {[catch {
|
||||
CheckFileName $slave $realfile
|
||||
CheckFileName $child $realfile
|
||||
} msg]} {
|
||||
Log $slave "$realfile:$msg"
|
||||
Log $child "$realfile:$msg"
|
||||
return -code error $msg
|
||||
}
|
||||
|
||||
# Passed all the tests, lets source it. Note that we do this all manually
|
||||
# because we want to control [info script] in the slave so information
|
||||
# because we want to control [info script] in the child so information
|
||||
# doesn't leak so much. [Bug 2913625]
|
||||
set old [::interp eval $slave {info script}]
|
||||
set old [::interp eval $child {info script}]
|
||||
set replacementMsg "script error"
|
||||
set code [catch {
|
||||
set f [open $realfile]
|
||||
@@ -891,17 +891,17 @@ proc ::safe::AliasSource {slave args} {
|
||||
}
|
||||
set contents [read $f]
|
||||
close $f
|
||||
::interp eval $slave [list info script $file]
|
||||
::interp eval $child [list info script $file]
|
||||
} msg opt]
|
||||
if {$code == 0} {
|
||||
set code [catch {::interp eval $slave $contents} msg opt]
|
||||
set code [catch {::interp eval $child $contents} msg opt]
|
||||
set replacementMsg $msg
|
||||
}
|
||||
catch {interp eval $slave [list info script $old]}
|
||||
catch {interp eval $child [list info script $old]}
|
||||
# Note that all non-errors are fine result codes from [source], so we must
|
||||
# take a little care to do it properly. [Bug 2923613]
|
||||
if {$code == 1} {
|
||||
Log $slave $msg
|
||||
Log $child $msg
|
||||
return -code error $replacementMsg
|
||||
}
|
||||
return -code $code -options $opt $msg
|
||||
@@ -909,18 +909,18 @@ proc ::safe::AliasSource {slave args} {
|
||||
|
||||
# AliasLoad is the target of the "load" alias in safe interpreters.
|
||||
|
||||
proc ::safe::AliasLoad {slave file args} {
|
||||
proc ::safe::AliasLoad {child file args} {
|
||||
set argc [llength $args]
|
||||
if {$argc > 2} {
|
||||
set msg "load error: too many arguments"
|
||||
Log $slave "$msg ($argc) {$file $args}"
|
||||
Log $child "$msg ($argc) {$file $args}"
|
||||
return -code error $msg
|
||||
}
|
||||
|
||||
# package name (can be empty if file is not).
|
||||
set package [lindex $args 0]
|
||||
|
||||
namespace upvar ::safe S$slave state
|
||||
namespace upvar ::safe S$child state
|
||||
|
||||
# Determine where to load. load use a relative interp path and {}
|
||||
# means self, so we can directly and safely use passed arg.
|
||||
@@ -929,7 +929,7 @@ proc ::safe::AliasLoad {slave file args} {
|
||||
# we will try to load into a sub sub interp; check that we want to
|
||||
# authorize that.
|
||||
if {!$state(nestedok)} {
|
||||
Log $slave "loading to a sub interp (nestedok)\
|
||||
Log $child "loading to a sub interp (nestedok)\
|
||||
disabled (trying to load $package to $target)"
|
||||
return -code error "permission denied (nested load)"
|
||||
}
|
||||
@@ -940,11 +940,11 @@ proc ::safe::AliasLoad {slave file args} {
|
||||
# static package loading
|
||||
if {$package eq ""} {
|
||||
set msg "load error: empty filename and no package name"
|
||||
Log $slave $msg
|
||||
Log $child $msg
|
||||
return -code error $msg
|
||||
}
|
||||
if {!$state(staticsok)} {
|
||||
Log $slave "static packages loading disabled\
|
||||
Log $child "static packages loading disabled\
|
||||
(trying to load $package to $target)"
|
||||
return -code error "permission denied (static package)"
|
||||
}
|
||||
@@ -953,36 +953,36 @@ proc ::safe::AliasLoad {slave file args} {
|
||||
|
||||
# get the real path from the virtual one.
|
||||
try {
|
||||
set file [TranslatePath $slave $file]
|
||||
set file [TranslatePath $child $file]
|
||||
} on error msg {
|
||||
Log $slave $msg
|
||||
Log $child $msg
|
||||
return -code error "permission denied"
|
||||
}
|
||||
|
||||
# check the translated path
|
||||
try {
|
||||
FileInAccessPath $slave $file
|
||||
FileInAccessPath $child $file
|
||||
} on error msg {
|
||||
Log $slave $msg
|
||||
Log $child $msg
|
||||
return -code error "permission denied (path)"
|
||||
}
|
||||
}
|
||||
|
||||
try {
|
||||
return [::interp invokehidden $slave load $file $package $target]
|
||||
return [::interp invokehidden $child load $file $package $target]
|
||||
} on error msg {
|
||||
Log $slave $msg
|
||||
Log $child $msg
|
||||
return -code error $msg
|
||||
}
|
||||
}
|
||||
|
||||
# FileInAccessPath raises an error if the file is not found in the list of
|
||||
# directories contained in the (master side recorded) slave's access path.
|
||||
# directories contained in the (parent side recorded) child's access path.
|
||||
|
||||
# the security here relies on "file dirname" answering the proper
|
||||
# result... needs checking ?
|
||||
proc ::safe::FileInAccessPath {slave file} {
|
||||
namespace upvar ::safe S$slave state
|
||||
proc ::safe::FileInAccessPath {child file} {
|
||||
namespace upvar ::safe S$child state
|
||||
set access_path $state(access_path)
|
||||
|
||||
if {[file isdirectory $file]} {
|
||||
@@ -994,14 +994,14 @@ proc ::safe::FileInAccessPath {slave file} {
|
||||
# potential pathname anomalies.
|
||||
set norm_parent [file normalize $parent]
|
||||
|
||||
namespace upvar ::safe S$slave state
|
||||
namespace upvar ::safe S$child state
|
||||
if {$norm_parent ni $state(access_path,norm)} {
|
||||
return -code error "\"$file\": not in access_path"
|
||||
}
|
||||
}
|
||||
|
||||
proc ::safe::DirInAccessPath {slave dir} {
|
||||
namespace upvar ::safe S$slave state
|
||||
proc ::safe::DirInAccessPath {child dir} {
|
||||
namespace upvar ::safe S$child state
|
||||
set access_path $state(access_path)
|
||||
|
||||
if {[file isfile $dir]} {
|
||||
@@ -1012,7 +1012,7 @@ proc ::safe::DirInAccessPath {slave dir} {
|
||||
# potential pathname anomalies.
|
||||
set norm_dir [file normalize $dir]
|
||||
|
||||
namespace upvar ::safe S$slave state
|
||||
namespace upvar ::safe S$child state
|
||||
if {$norm_dir ni $state(access_path,norm)} {
|
||||
return -code error "\"$dir\": not in access_path"
|
||||
}
|
||||
@@ -1021,16 +1021,16 @@ proc ::safe::DirInAccessPath {slave dir} {
|
||||
# This procedure is used to report an attempt to use an unsafe member of an
|
||||
# ensemble command.
|
||||
|
||||
proc ::safe::BadSubcommand {slave command subcommand args} {
|
||||
proc ::safe::BadSubcommand {child command subcommand args} {
|
||||
set msg "not allowed to invoke subcommand $subcommand of $command"
|
||||
Log $slave $msg
|
||||
Log $child $msg
|
||||
return -code error -errorcode {TCL SAFE SUBCOMMAND} $msg
|
||||
}
|
||||
|
||||
# AliasEncoding is the target of the "encoding" alias in safe interpreters.
|
||||
|
||||
proc ::safe::AliasEncoding {slave option args} {
|
||||
# Note that [encoding dirs] is not supported in safe slaves at all
|
||||
proc ::safe::AliasEncoding {child option args} {
|
||||
# Note that [encoding dirs] is not supported in safe children at all
|
||||
set subcommands {convertfrom convertto names system}
|
||||
try {
|
||||
set option [tcl::prefix match -error [list -level 1 -errorcode \
|
||||
@@ -1041,15 +1041,15 @@ proc ::safe::AliasEncoding {slave option args} {
|
||||
"wrong # args: should be \"encoding system\""
|
||||
}
|
||||
} on error {msg options} {
|
||||
Log $slave $msg
|
||||
Log $child $msg
|
||||
return -options $options $msg
|
||||
}
|
||||
tailcall ::interp invokehidden $slave encoding $option {*}$args
|
||||
tailcall ::interp invokehidden $child encoding $option {*}$args
|
||||
}
|
||||
|
||||
# Various minor hiding of platform features. [Bug 2913625]
|
||||
|
||||
proc ::safe::AliasExeName {slave} {
|
||||
proc ::safe::AliasExeName {child} {
|
||||
return ""
|
||||
}
|
||||
|
||||
@@ -1062,7 +1062,7 @@ proc ::safe::Setup {} {
|
||||
|
||||
# Share the descriptions
|
||||
set temp [::tcl::OptKeyRegister {
|
||||
{-accessPath -list {} "access path for the slave"}
|
||||
{-accessPath -list {} "access path for the child"}
|
||||
{-noStatics "prevent loading of statically linked pkgs"}
|
||||
{-statics true "loading of statically linked pkgs"}
|
||||
{-nestedLoadOk "allow nested loading"}
|
||||
@@ -1070,18 +1070,18 @@ proc ::safe::Setup {} {
|
||||
{-deleteHook -script {} "delete hook"}
|
||||
}]
|
||||
|
||||
# create case (slave is optional)
|
||||
# create case (child is optional)
|
||||
::tcl::OptKeyRegister {
|
||||
{?slave? -name {} "name of the slave (optional)"}
|
||||
{?child? -name {} "name of the child (optional)"}
|
||||
} ::safe::interpCreate
|
||||
|
||||
# adding the flags sub programs to the command program (relying on Opt's
|
||||
# internal implementation details)
|
||||
lappend ::tcl::OptDesc(::safe::interpCreate) $::tcl::OptDesc($temp)
|
||||
|
||||
# init and configure (slave is needed)
|
||||
# init and configure (child is needed)
|
||||
::tcl::OptKeyRegister {
|
||||
{slave -name {} "name of the slave"}
|
||||
{child -name {} "name of the child"}
|
||||
} ::safe::interpIC
|
||||
|
||||
# adding the flags sub programs to the command program (relying on Opt's
|
||||
@@ -1111,20 +1111,20 @@ namespace eval ::safe {
|
||||
# Log command, set via 'setLogCmd'. Logging is disabled when empty.
|
||||
variable Log {}
|
||||
|
||||
# The package maintains a state array per slave interp under its
|
||||
# The package maintains a state array per child interp under its
|
||||
# control. The name of this array is S<interp-name>. This array is
|
||||
# brought into scope where needed, using 'namespace upvar'. The S
|
||||
# prefix is used to avoid that a slave interp called "Log" smashes
|
||||
# prefix is used to avoid that a child interp called "Log" smashes
|
||||
# the "Log" variable.
|
||||
#
|
||||
# The array's elements are:
|
||||
#
|
||||
# access_path : List of paths accessible to the slave.
|
||||
# access_path : List of paths accessible to the child.
|
||||
# access_path,norm : Ditto, in normalized form.
|
||||
# access_path,slave : Ditto, as the path tokens as seen by the slave.
|
||||
# access_path,child : Ditto, as the path tokens as seen by the child.
|
||||
# access_path,map : dict ( token -> path )
|
||||
# access_path,remap : dict ( path -> token )
|
||||
# tm_path_slave : List of TM root directories, as tokens seen by the slave.
|
||||
# tm_path_child : List of TM root directories, as tokens seen by the child.
|
||||
# staticsok : Value of option -statics
|
||||
# nestedok : Value of option -nested
|
||||
# cleanupHook : Value of option -deleteHook
|
||||
|
||||
@@ -359,9 +359,9 @@ test appendComp-7.9 {append var does not trigger read trace} -setup {
|
||||
} -result {0}
|
||||
|
||||
test appendComp-8.1 {defer error to runtime} -setup {
|
||||
interp create slave
|
||||
interp create child
|
||||
} -body {
|
||||
slave eval {
|
||||
child eval {
|
||||
proc foo {} {
|
||||
proc append args {}
|
||||
append
|
||||
@@ -369,7 +369,7 @@ test appendComp-8.1 {defer error to runtime} -setup {
|
||||
foo
|
||||
}
|
||||
} -cleanup {
|
||||
interp delete slave
|
||||
interp delete child
|
||||
} -result {}
|
||||
|
||||
# New tests for bug 3057639 to show off the more consistent behaviour of
|
||||
|
||||
+3
-3
@@ -1003,13 +1003,13 @@ test basic-49.2 {Tcl_EvalEx: verify TCL_EVAL_GLOBAL operation} testevalex {
|
||||
} {global}
|
||||
|
||||
test basic-50.1 {[586e71dce4] EvalObjv level #0 exception handling} -setup {
|
||||
interp create slave
|
||||
interp alias {} foo slave return
|
||||
interp create child
|
||||
interp alias {} foo child return
|
||||
} -body {
|
||||
list [catch foo m] $m
|
||||
} -cleanup {
|
||||
unset -nocomplain m
|
||||
interp delete slave
|
||||
interp delete child
|
||||
} -result {0 {}}
|
||||
|
||||
# Clean up after expand tests
|
||||
|
||||
+1
-1
@@ -1638,7 +1638,7 @@ test cmdAH-31.9 {Tcl_FileObjCmd: channels in other interp} {
|
||||
lsort [safeInterp eval [list file channels]]
|
||||
} [lsort [list stdout $newFileId]]
|
||||
test cmdAH-31.10 {Tcl_FileObjCmd: channels in other interp} {
|
||||
# we can now write to $newFileId from slave
|
||||
# we can now write to $newFileId from child
|
||||
safeInterp eval [list puts $newFileId "hello"]
|
||||
} {}
|
||||
interp transfer {} $newFileId safeInterp
|
||||
|
||||
+3
-3
@@ -353,9 +353,9 @@ test compExpr-7.1 {Memory Leak} -constraints memory -setup {
|
||||
} -body {
|
||||
set end [getbytes]
|
||||
for {set i 0} {$i < 5} {incr i} {
|
||||
interp create slave
|
||||
slave eval expr 1+2+3+4+5+6+7+8+9+10+11+12+13
|
||||
interp delete slave
|
||||
interp create child
|
||||
child eval expr 1+2+3+4+5+6+7+8+9+10+11+12+13
|
||||
interp delete child
|
||||
set tmp $end
|
||||
set end [getbytes]
|
||||
}
|
||||
|
||||
@@ -771,25 +771,25 @@ test coroutine-8.0.1 {coro inject after error} -body {
|
||||
lappend ::result [catch {demo} err] $err
|
||||
} -result {inject-executed 1 test}
|
||||
test coroutine-8.1.1 {coro inject, ticket 42202ba1e5ff566e} -body {
|
||||
interp create slave
|
||||
slave eval {
|
||||
interp create child
|
||||
child eval {
|
||||
coroutine demo apply {{} { while {1} yield }}
|
||||
demo
|
||||
tcl::unsupported::inject demo set ::result inject-executed
|
||||
}
|
||||
interp delete slave
|
||||
interp delete child
|
||||
} -result {}
|
||||
test coroutine-8.1.2 {coro inject with result, ticket 42202ba1e5ff566e} -body {
|
||||
interp create slave
|
||||
slave eval {
|
||||
interp create child
|
||||
child eval {
|
||||
coroutine demo apply {{} { while {1} yield }}
|
||||
demo
|
||||
tcl::unsupported::inject demo set ::result inject-executed
|
||||
}
|
||||
slave eval demo
|
||||
set result [slave eval {set ::result}]
|
||||
child eval demo
|
||||
set result [child eval {set ::result}]
|
||||
|
||||
interp delete slave
|
||||
interp delete child
|
||||
set result
|
||||
} -result {inject-executed}
|
||||
|
||||
|
||||
+2
-2
@@ -324,11 +324,11 @@ test env-5.2 {corner cases - unset the env array} -setup {
|
||||
} -result {0}
|
||||
|
||||
|
||||
test env-5.3 {corner cases: unset the env in master should unset child} -setup {
|
||||
test env-5.3 {corner cases: unset the env in parent should unset child} -setup {
|
||||
setup1
|
||||
interp create i
|
||||
} -body {
|
||||
# Variables deleted in a master interp should be deleted in child interp
|
||||
# Variables deleted in a parent interp should be deleted in child interp
|
||||
# too.
|
||||
i eval {set env(THIS_SHOULD_EXIST) a}
|
||||
set result [set env(THIS_SHOULD_EXIST)]
|
||||
|
||||
+50
-50
@@ -657,56 +657,56 @@ test execute-6.8 {TclCompEvalObj: bytecode name resolution epoch validation} -se
|
||||
namespace delete foo
|
||||
} -result {0 AHA!}
|
||||
test execute-6.9 {TclCompEvalObj: bytecode interp validation} -setup {
|
||||
interp create slave
|
||||
interp create child
|
||||
} -body {
|
||||
set script { llength {} }
|
||||
slave eval {proc llength args {return AHA!}}
|
||||
child eval {proc llength args {return AHA!}}
|
||||
set result {}
|
||||
lappend result [if 1 $script]
|
||||
lappend result [slave eval $script]
|
||||
lappend result [child eval $script]
|
||||
} -cleanup {
|
||||
interp delete slave
|
||||
interp delete child
|
||||
} -result {0 AHA!}
|
||||
test execute-6.10 {TclCompEvalObj: bytecode interp validation} -body {
|
||||
set script { llength {} }
|
||||
interp create slave
|
||||
interp create child
|
||||
set result {}
|
||||
lappend result [slave eval $script]
|
||||
interp delete slave
|
||||
interp create slave
|
||||
lappend result [slave eval $script]
|
||||
lappend result [child eval $script]
|
||||
interp delete child
|
||||
interp create child
|
||||
lappend result [child eval $script]
|
||||
} -cleanup {
|
||||
catch {interp delete slave}
|
||||
catch {interp delete child}
|
||||
} -result {0 0}
|
||||
test execute-6.11 {Tcl_ExprObj: exprcode interp validation} -setup {
|
||||
interp create slave
|
||||
interp create child
|
||||
} -constraints testexprlongobj -body {
|
||||
set e { [llength {}]+1 }
|
||||
set result {}
|
||||
load {} Tcltest slave
|
||||
interp alias {} e slave testexprlongobj
|
||||
load {} Tcltest child
|
||||
interp alias {} e child testexprlongobj
|
||||
lappend result [e $e]
|
||||
interp delete slave
|
||||
interp create slave
|
||||
load {} Tcltest slave
|
||||
interp alias {} e slave testexprlongobj
|
||||
interp delete child
|
||||
interp create child
|
||||
load {} Tcltest child
|
||||
interp alias {} e child testexprlongobj
|
||||
lappend result [e $e]
|
||||
} -cleanup {
|
||||
interp delete slave
|
||||
interp delete child
|
||||
} -result {{This is a result: 1} {This is a result: 1}}
|
||||
test execute-6.12 {Tcl_ExprObj: exprcode interp validation} -setup {
|
||||
interp create slave
|
||||
interp create child
|
||||
} -body {
|
||||
set e { [llength {}]+1 }
|
||||
set result {}
|
||||
interp alias {} e slave expr
|
||||
interp alias {} e child expr
|
||||
lappend result [e $e]
|
||||
interp delete slave
|
||||
interp create slave
|
||||
interp alias {} e slave expr
|
||||
interp delete child
|
||||
interp create child
|
||||
interp alias {} e child expr
|
||||
lappend result [e $e]
|
||||
} -cleanup {
|
||||
interp delete slave
|
||||
interp delete child
|
||||
} -result {1 1}
|
||||
test execute-6.13 {Tcl_ExprObj: exprcode epoch validation} -body {
|
||||
set e { [llength {}]+1 }
|
||||
@@ -747,16 +747,16 @@ test execute-6.15 {Tcl_ExprObj: exprcode name resolution epoch validation} -setu
|
||||
namespace delete foo
|
||||
} -result {1 2}
|
||||
test execute-6.16 {Tcl_ExprObj: exprcode interp validation} -setup {
|
||||
interp create slave
|
||||
interp create child
|
||||
} -body {
|
||||
set e { [llength {}]+1 }
|
||||
interp alias {} e slave expr
|
||||
slave eval {proc llength args {return 1}}
|
||||
interp alias {} e child expr
|
||||
child eval {proc llength args {return 1}}
|
||||
set result {}
|
||||
lappend result [expr $e]
|
||||
lappend result [e $e]
|
||||
} -cleanup {
|
||||
interp delete slave
|
||||
interp delete child
|
||||
} -result {1 2}
|
||||
test execute-6.17 {Tcl_ExprObj: exprcode context validation} -body {
|
||||
proc foo e {set v 0; expr $e}
|
||||
@@ -982,8 +982,8 @@ test execute-8.5 {Bug 2038069} -setup {
|
||||
"catch \[list error FOO\] m o"} -errorline 2}
|
||||
|
||||
test execute-8.6 {Compile epoch bump in global level (bug [fa6bf38d07])} -setup {
|
||||
interp create slave
|
||||
slave eval {
|
||||
interp create child
|
||||
child eval {
|
||||
package require tcltest
|
||||
catch [list package require -exact Tcltest [info patchlevel]]
|
||||
::tcltest::loadTestedCommands
|
||||
@@ -992,31 +992,31 @@ test execute-8.6 {Compile epoch bump in global level (bug [fa6bf38d07])} -setup
|
||||
}
|
||||
}
|
||||
} -body {
|
||||
slave eval {
|
||||
child eval {
|
||||
lappend res A; testbumpinterpepoch; lappend res B; return; lappend res C;
|
||||
}
|
||||
slave eval {
|
||||
child eval {
|
||||
set i 0; while {[incr i] < 3} {
|
||||
lappend res A; testbumpinterpepoch; lappend res B; return; lappend res C;
|
||||
}
|
||||
}
|
||||
slave eval {
|
||||
child eval {
|
||||
set i 0; while {[incr i] < 3} {
|
||||
lappend res A; testbumpinterpepoch; lappend res B; break; lappend res C;
|
||||
}
|
||||
}
|
||||
slave eval {
|
||||
child eval {
|
||||
catch {
|
||||
lappend res A; testbumpinterpepoch; lappend res B; error test; lappend res C;
|
||||
}
|
||||
}
|
||||
slave eval {set res}
|
||||
child eval {set res}
|
||||
} -cleanup {
|
||||
interp delete slave
|
||||
interp delete child
|
||||
} -result [lrepeat 4 A B]
|
||||
test execute-8.7 {Compile epoch bump in global level (bug [fa6bf38d07]), exception case} -setup {
|
||||
interp create slave
|
||||
slave eval {
|
||||
interp create child
|
||||
child eval {
|
||||
package require tcltest
|
||||
catch [list package require -exact Tcltest [info patchlevel]]
|
||||
::tcltest::loadTestedCommands
|
||||
@@ -1027,28 +1027,28 @@ test execute-8.7 {Compile epoch bump in global level (bug [fa6bf38d07]), excepti
|
||||
} -body {
|
||||
set res {}
|
||||
lappend res [catch {
|
||||
slave eval {
|
||||
child eval {
|
||||
lappend res A; testbumpinterpepoch; lappend res B; return -code error test; lappend res C;
|
||||
}
|
||||
} e] $e
|
||||
lappend res [catch {
|
||||
slave eval {
|
||||
child eval {
|
||||
lappend res A; testbumpinterpepoch; lappend res B; error test; lappend res C;
|
||||
}
|
||||
} e] $e
|
||||
lappend res [catch {
|
||||
slave eval {
|
||||
child eval {
|
||||
lappend res A; testbumpinterpepoch; lappend res B; return -code return test; lappend res C;
|
||||
}
|
||||
} e] $e
|
||||
lappend res [catch {
|
||||
slave eval {
|
||||
child eval {
|
||||
lappend res A; testbumpinterpepoch; lappend res B; break; lappend res C;
|
||||
}
|
||||
} e] $e
|
||||
list $res [slave eval {set res}]
|
||||
list $res [child eval {set res}]
|
||||
} -cleanup {
|
||||
interp delete slave
|
||||
interp delete child
|
||||
} -result [list {1 test 1 test 2 test 3 {}} [lrepeat 4 A B]]
|
||||
|
||||
test execute-9.1 {Interp result resetting [Bug 1522803]} {
|
||||
@@ -1069,16 +1069,16 @@ test execute-10.1 {TclExecuteByteCode, INST_CONCAT1, bytearrays} {
|
||||
apply {s {binary scan $s c x; list $x [scan $s$s %c%c]}} \u0130
|
||||
} {48 {304 304}}
|
||||
test execute-10.2 {Bug 2802881} -setup {
|
||||
interp create slave
|
||||
interp create child
|
||||
} -body {
|
||||
# If [Bug 2802881] is not fixed, this will segfault
|
||||
slave eval {
|
||||
child eval {
|
||||
trace add variable ::errorInfo write {expr {$foo} ;#}
|
||||
proc demo {} {a {}{}}
|
||||
demo
|
||||
}
|
||||
} -cleanup {
|
||||
interp delete slave
|
||||
interp delete child
|
||||
} -returnCodes error -match glob -result *
|
||||
test execute-10.3 {Bug 3072640} -setup {
|
||||
proc generate {n} {
|
||||
@@ -1103,9 +1103,9 @@ test execute-10.3 {Bug 3072640} -setup {
|
||||
} -result 4
|
||||
|
||||
test execute-11.1 {Bug 3142026: GrowEvaluationStack off-by-one} -setup {
|
||||
interp create slave
|
||||
interp create child
|
||||
} -body {
|
||||
slave eval {
|
||||
child eval {
|
||||
set x [lrepeat 1320 199]
|
||||
for {set i 0} {$i < 20} {incr i} {
|
||||
lappend x $i
|
||||
@@ -1115,7 +1115,7 @@ test execute-11.1 {Bug 3142026: GrowEvaluationStack off-by-one} -setup {
|
||||
return ok
|
||||
}
|
||||
} -cleanup {
|
||||
interp delete slave
|
||||
interp delete child
|
||||
} -result ok
|
||||
|
||||
test execute-11.2 {Bug 268b23df11} -setup {
|
||||
|
||||
+1
-1
@@ -19,7 +19,7 @@ if {[catch {package require http 2} version]} {
|
||||
catch {puts "Cannot load http 2.* package"}
|
||||
return
|
||||
} else {
|
||||
catch {puts "Running http 2.* tests in slave interp"}
|
||||
catch {puts "Running http 2.* tests in child interp"}
|
||||
set interp [interp create http2]
|
||||
$interp eval [list set http2 "running"]
|
||||
$interp eval [list set argv $argv]
|
||||
|
||||
+1
-1
@@ -22,7 +22,7 @@ if {[catch {package require http 1.0}]} {
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
} else {
|
||||
catch {puts "Running http 1.0 tests in slave interp"}
|
||||
catch {puts "Running http 1.0 tests in child interp"}
|
||||
set interp [interp create httpold]
|
||||
$interp eval [list set httpold "running"]
|
||||
$interp eval [list set argv $argv]
|
||||
|
||||
+247
-247
File diff suppressed because it is too large
Load Diff
+3
-3
@@ -8660,16 +8660,16 @@ test io-74.1 {[104f2885bb] improper cache validity check} -setup {
|
||||
set fn [makeFile {} io-74.1]
|
||||
set rfd [open $fn r]
|
||||
testobj freeallvars
|
||||
interp create slave
|
||||
interp create child
|
||||
} -constraints testobj -body {
|
||||
teststringobj set 1 [string range $rfd 0 end]
|
||||
read [teststringobj get 1]
|
||||
testobj duplicate 1 2
|
||||
interp transfer {} $rfd slave
|
||||
interp transfer {} $rfd child
|
||||
catch {read [teststringobj get 1]}
|
||||
read [teststringobj get 2]
|
||||
} -cleanup {
|
||||
interp delete slave
|
||||
interp delete child
|
||||
testobj freeallvars
|
||||
removeFile io-74.1
|
||||
} -returnCodes error -match glob -result {can not find channel named "*"}
|
||||
|
||||
+5
-5
@@ -2029,7 +2029,7 @@ test iocmd-32.0 {origin interpreter of moved channel gone} -match glob -body {
|
||||
set ida [interp create];#puts <<$ida>>
|
||||
set idb [interp create];#puts <<$idb>>
|
||||
|
||||
# Magic to get the test* commands in the slaves
|
||||
# Magic to get the test* commands in the children
|
||||
load {} Tcltest $ida
|
||||
load {} Tcltest $idb
|
||||
|
||||
@@ -2067,7 +2067,7 @@ test iocmd-32.1 {origin interpreter of moved channel destroyed during access} -m
|
||||
set ida [interp create];#puts <<$ida>>
|
||||
set idb [interp create];#puts <<$idb>>
|
||||
|
||||
# Magic to get the test* commands in the slaves
|
||||
# Magic to get the test* commands in the children
|
||||
load {} Tcltest $ida
|
||||
load {} Tcltest $idb
|
||||
|
||||
@@ -2109,13 +2109,13 @@ test iocmd-32.2 {delete interp of reflected chan} {
|
||||
# Bug 3034840
|
||||
# Run this test in an interp with memory debugging to panic
|
||||
# on the double free
|
||||
interp create slave
|
||||
slave eval {
|
||||
interp create child
|
||||
child eval {
|
||||
proc no-op args {}
|
||||
proc driver {sub args} {return {initialize finalize watch read}}
|
||||
chan event [chan create read driver] readable no-op
|
||||
}
|
||||
interp delete slave
|
||||
interp delete child
|
||||
} {}
|
||||
|
||||
# ### ### ### ######### ######### #########
|
||||
|
||||
+10
-10
@@ -1162,7 +1162,7 @@ test iortrans-8.3 {chan flush, bug 2921116} -match glob -setup {
|
||||
test iortrans-11.0 {origin interpreter of moved transform gone} -setup {
|
||||
set ida [interp create]; #puts <<$ida>>
|
||||
set idb [interp create]; #puts <<$idb>>
|
||||
# Magic to get the test* commands in the slaves
|
||||
# Magic to get the test* commands in the children
|
||||
load {} Tcltest $ida
|
||||
load {} Tcltest $idb
|
||||
} -constraints {testchannel} -match glob -body {
|
||||
@@ -1205,7 +1205,7 @@ test iortrans-11.0 {origin interpreter of moved transform gone} -setup {
|
||||
test iortrans-11.1 {origin interpreter of moved transform destroyed during access} -setup {
|
||||
set ida [interp create]; #puts <<$ida>>
|
||||
set idb [interp create]; #puts <<$idb>>
|
||||
# Magic to get the test* commands in the slaves
|
||||
# Magic to get the test* commands in the children
|
||||
load {} Tcltest $ida
|
||||
load {} Tcltest $idb
|
||||
} -constraints {testchannel} -match glob -body {
|
||||
@@ -1244,16 +1244,16 @@ test iortrans-11.1 {origin interpreter of moved transform destroyed during acces
|
||||
tempdone
|
||||
} -result {Owner lost}
|
||||
test iortrans-11.2 {delete interp of reflected transform} -setup {
|
||||
interp create slave
|
||||
# Magic to get the test* commands into the slave
|
||||
load {} Tcltest slave
|
||||
interp create child
|
||||
# Magic to get the test* commands into the child
|
||||
load {} Tcltest child
|
||||
} -constraints {testchannel} -body {
|
||||
# Get base channel into the slave
|
||||
# Get base channel into the child
|
||||
set c [tempchan]
|
||||
testchannel cut $c
|
||||
interp eval slave [list testchannel splice $c]
|
||||
interp eval slave [list set c $c]
|
||||
slave eval {
|
||||
interp eval child [list testchannel splice $c]
|
||||
interp eval child [list set c $c]
|
||||
child eval {
|
||||
proc no-op args {}
|
||||
proc driver {c sub args} {
|
||||
return {initialize finalize read write}
|
||||
@@ -1261,7 +1261,7 @@ test iortrans-11.2 {delete interp of reflected transform} -setup {
|
||||
set t [chan push $c [list driver $c]]
|
||||
chan event $c readable no-op
|
||||
}
|
||||
interp delete slave
|
||||
interp delete child
|
||||
} -cleanup {
|
||||
tempdone
|
||||
} -result {}
|
||||
|
||||
+1
-1
@@ -103,7 +103,7 @@ test load-3.1 {error in _Init procedure, same interpreter} \
|
||||
"if 44 {open non_existent}"
|
||||
invoked from within
|
||||
"load [file join $testDir pkge$ext] pkge"} {POSIX ENOENT {no such file or directory}}}
|
||||
test load-3.2 {error in _Init procedure, slave interpreter} \
|
||||
test load-3.2 {error in _Init procedure, child interpreter} \
|
||||
[list $dll $loaded] {
|
||||
catch {interp delete x}
|
||||
interp create x
|
||||
|
||||
+29
-29
@@ -179,21 +179,21 @@ test namespace-7.6 {recursive Tcl_DeleteNamespace, no active call frames in ns}
|
||||
namespace delete test_ns_2
|
||||
} {}
|
||||
test namespace-7.7 {Bug 1655305} -setup {
|
||||
interp create slave
|
||||
interp create child
|
||||
# Can't invoke through the ensemble, since deleting the global namespace
|
||||
# (indirectly, via deleting ::tcl) deletes the ensemble.
|
||||
slave eval {rename ::tcl::info::commands ::infocommands}
|
||||
slave hide infocommands
|
||||
slave eval {
|
||||
child eval {rename ::tcl::info::commands ::infocommands}
|
||||
child hide infocommands
|
||||
child eval {
|
||||
proc foo {} {
|
||||
namespace delete ::
|
||||
}
|
||||
}
|
||||
} -body {
|
||||
slave eval foo
|
||||
slave invokehidden infocommands
|
||||
child eval foo
|
||||
child invokehidden infocommands
|
||||
} -cleanup {
|
||||
interp delete slave
|
||||
interp delete child
|
||||
} -result {}
|
||||
|
||||
test namespace-7.8 {Bug ba1419303b4c} -setup {
|
||||
@@ -269,28 +269,28 @@ test namespace-8.4 {TclTeardownNamespace, cmds imported from deleted ns go away}
|
||||
[info commands test_ns_import::*]
|
||||
} [list [lsort {::test_ns_import::p ::test_ns_import::cmd1 ::test_ns_import::cmd2}] {} ::test_ns_import::p]
|
||||
test namespace-8.5 {TclTeardownNamespace: preserve errorInfo; errorCode values} {
|
||||
interp create slave
|
||||
slave eval {trace add execution error leave {namespace delete :: ;#}}
|
||||
catch {slave eval error foo bar baz}
|
||||
interp delete slave
|
||||
interp create child
|
||||
child eval {trace add execution error leave {namespace delete :: ;#}}
|
||||
catch {child eval error foo bar baz}
|
||||
interp delete child
|
||||
set ::errorInfo
|
||||
} {bar
|
||||
invoked from within
|
||||
"slave eval error foo bar baz"}
|
||||
"child eval error foo bar baz"}
|
||||
test namespace-8.6 {TclTeardownNamespace: preserve errorInfo; errorCode values} {
|
||||
interp create slave
|
||||
slave eval {trace add variable errorCode write {namespace delete :: ;#}}
|
||||
catch {slave eval error foo bar baz}
|
||||
interp delete slave
|
||||
interp create child
|
||||
child eval {trace add variable errorCode write {namespace delete :: ;#}}
|
||||
catch {child eval error foo bar baz}
|
||||
interp delete child
|
||||
set ::errorInfo
|
||||
} {bar
|
||||
invoked from within
|
||||
"slave eval error foo bar baz"}
|
||||
"child eval error foo bar baz"}
|
||||
test namespace-8.7 {TclTeardownNamespace: preserve errorInfo; errorCode values} {
|
||||
interp create slave
|
||||
slave eval {trace add execution error leave {namespace delete :: ;#}}
|
||||
catch {slave eval error foo bar baz}
|
||||
interp delete slave
|
||||
interp create child
|
||||
child eval {trace add execution error leave {namespace delete :: ;#}}
|
||||
catch {child eval error foo bar baz}
|
||||
interp delete child
|
||||
set ::errorCode
|
||||
} baz
|
||||
|
||||
@@ -2797,9 +2797,9 @@ test namespace-51.15 {namespace resolution path control} -body {
|
||||
namespace delete ::test_ns_2
|
||||
}
|
||||
test namespace-51.16 {Bug 1566526} {
|
||||
interp create slave
|
||||
slave eval namespace eval demo namespace path ::
|
||||
interp delete slave
|
||||
interp create child
|
||||
child eval namespace eval demo namespace path ::
|
||||
interp delete child
|
||||
} {}
|
||||
test namespace-51.17 {resolution epoch handling: Bug 2898722} -setup {
|
||||
set result {}
|
||||
@@ -3000,19 +3000,19 @@ test namespace-52.11 {unknown: with TCL_EVAL_INVOKE} -setup {
|
||||
}
|
||||
}
|
||||
catch {rename ::noSuchCommand {}}
|
||||
set ::slave [interp create]
|
||||
set ::child [interp create]
|
||||
} -body {
|
||||
$::slave alias bar noSuchCommand
|
||||
$::child alias bar noSuchCommand
|
||||
namespace eval test_ns_1 {
|
||||
namespace unknown unknown
|
||||
proc unknown args {
|
||||
return FAIL
|
||||
}
|
||||
$::slave eval bar
|
||||
$::child eval bar
|
||||
}
|
||||
} -cleanup {
|
||||
interp delete $::slave
|
||||
unset ::slave
|
||||
interp delete $::child
|
||||
unset ::child
|
||||
namespace delete test_ns_1
|
||||
rename ::unknown {}
|
||||
rename unknown.save ::unknown
|
||||
|
||||
+77
-77
@@ -306,19 +306,19 @@ test oo-1.18.2 {Bug 75b8433707: memory leak in oo-1.18} -setup {
|
||||
rename test-oo-1.18 {}
|
||||
} -result 0
|
||||
test oo-1.18.3 {Bug 21c144f0f5} -setup {
|
||||
interp create slave
|
||||
interp create child
|
||||
} -body {
|
||||
slave eval {
|
||||
child eval {
|
||||
oo::define [oo::class create foo] superclass oo::class
|
||||
oo::class destroy
|
||||
}
|
||||
} -cleanup {
|
||||
interp delete slave
|
||||
interp delete child
|
||||
}
|
||||
test oo-1.18.4 {correct handling of cleanup in superclass set error} -setup {
|
||||
interp create slave
|
||||
interp create child
|
||||
} -body {
|
||||
slave eval {
|
||||
child eval {
|
||||
oo::class create A
|
||||
oo::class create B {
|
||||
superclass oo::class
|
||||
@@ -330,12 +330,12 @@ test oo-1.18.4 {correct handling of cleanup in superclass set error} -setup {
|
||||
[B create C] create d
|
||||
}
|
||||
} -returnCodes error -cleanup {
|
||||
interp delete slave
|
||||
interp delete child
|
||||
} -result {class should only be a direct superclass once}
|
||||
test oo-1.18.5 {correct handling of cleanup in superclass set error} -setup {
|
||||
interp create slave
|
||||
interp create child
|
||||
} -body {
|
||||
slave eval {
|
||||
child eval {
|
||||
oo::class create A
|
||||
oo::class create B {
|
||||
superclass oo::class
|
||||
@@ -347,7 +347,7 @@ test oo-1.18.5 {correct handling of cleanup in superclass set error} -setup {
|
||||
[B create C {B C}] create d
|
||||
}
|
||||
} -returnCodes error -cleanup {
|
||||
interp delete slave
|
||||
interp delete child
|
||||
} -result {attempt to form circular dependency graph}
|
||||
test oo-1.19 {basic test of OO functionality: teardown order} -body {
|
||||
oo::object create o
|
||||
@@ -1370,16 +1370,16 @@ test oo-7.8 {OO: next at the end of the method chain} -setup {
|
||||
} -result {foo2 foo 1 {no next method implementation}}
|
||||
test oo-7.9 {OO: defining inheritance in namespaces} -setup {
|
||||
set ::result {}
|
||||
oo::class create ::master
|
||||
oo::class create ::parent
|
||||
namespace eval ::foo {
|
||||
oo::class create mixin {superclass ::master}
|
||||
oo::class create mixin {superclass ::parent}
|
||||
}
|
||||
} -cleanup {
|
||||
::master destroy
|
||||
::parent destroy
|
||||
namespace delete ::foo
|
||||
} -body {
|
||||
namespace eval ::foo {
|
||||
oo::class create bar {superclass master}
|
||||
oo::class create bar {superclass parent}
|
||||
oo::class create boo
|
||||
oo::define boo {superclass bar}
|
||||
oo::define boo {mixin mixin}
|
||||
@@ -2066,18 +2066,18 @@ test oo-14.5 {OO and mixins and filters - advanced case} -setup {
|
||||
mix destroy
|
||||
} -result >>foobar<<
|
||||
test oo-14.6 {OO and mixins of mixins - Bug 1960703} -setup {
|
||||
oo::class create master
|
||||
oo::class create parent
|
||||
} -cleanup {
|
||||
master destroy
|
||||
parent destroy
|
||||
} -body {
|
||||
oo::class create A {
|
||||
superclass master
|
||||
superclass parent
|
||||
method egg {} {
|
||||
return chicken
|
||||
}
|
||||
}
|
||||
oo::class create B {
|
||||
superclass master
|
||||
superclass parent
|
||||
mixin A
|
||||
method bar {} {
|
||||
# mixin from A
|
||||
@@ -2085,7 +2085,7 @@ test oo-14.6 {OO and mixins of mixins - Bug 1960703} -setup {
|
||||
}
|
||||
}
|
||||
oo::class create C {
|
||||
superclass master
|
||||
superclass parent
|
||||
mixin B
|
||||
method foo {} {
|
||||
# mixin from B
|
||||
@@ -2095,12 +2095,12 @@ test oo-14.6 {OO and mixins of mixins - Bug 1960703} -setup {
|
||||
[C new] foo
|
||||
} -result chicken
|
||||
test oo-14.7 {OO and filters from mixins of mixins} -setup {
|
||||
oo::class create master
|
||||
oo::class create parent
|
||||
} -cleanup {
|
||||
master destroy
|
||||
parent destroy
|
||||
} -body {
|
||||
oo::class create A {
|
||||
superclass master
|
||||
superclass parent
|
||||
method egg {} {
|
||||
return chicken
|
||||
}
|
||||
@@ -2111,7 +2111,7 @@ test oo-14.7 {OO and filters from mixins of mixins} -setup {
|
||||
}
|
||||
}
|
||||
oo::class create B {
|
||||
superclass master
|
||||
superclass parent
|
||||
mixin A
|
||||
filter f
|
||||
method bar {} {
|
||||
@@ -2120,7 +2120,7 @@ test oo-14.7 {OO and filters from mixins of mixins} -setup {
|
||||
}
|
||||
}
|
||||
oo::class create C {
|
||||
superclass master
|
||||
superclass parent
|
||||
mixin B
|
||||
filter f
|
||||
method foo {} {
|
||||
@@ -2132,18 +2132,18 @@ test oo-14.7 {OO and filters from mixins of mixins} -setup {
|
||||
} -result {(foo) (bar) (egg) chicken (egg) (bar) (foo)}
|
||||
test oo-14.8 {OO: class mixin order - Bug 1998221} -setup {
|
||||
set ::result {}
|
||||
oo::class create master {
|
||||
oo::class create parent {
|
||||
method test {} {}
|
||||
}
|
||||
} -cleanup {
|
||||
master destroy
|
||||
parent destroy
|
||||
} -body {
|
||||
oo::class create mix {
|
||||
superclass master
|
||||
superclass parent
|
||||
method test {} {lappend ::result mix; next; return $::result}
|
||||
}
|
||||
oo::class create cls {
|
||||
superclass master
|
||||
superclass parent
|
||||
mixin mix
|
||||
method test {} {lappend ::result cls; next; return $::result}
|
||||
}
|
||||
@@ -2778,13 +2778,13 @@ test oo-18.7 {OO: objdefine command support} -setup {
|
||||
invoked from within
|
||||
"oo::objdefine inst {rename ::inst ::INST;error foo}"}}
|
||||
test oo-18.8 {OO: define/self command support} -setup {
|
||||
oo::class create master
|
||||
oo::class create ::foo {superclass master}
|
||||
oo::class create parent
|
||||
oo::class create ::foo {superclass parent}
|
||||
} -body {
|
||||
catch {oo::define foo {rename ::foo ::bar; self {error foobar}}} msg opt
|
||||
dict get $opt -errorinfo
|
||||
} -cleanup {
|
||||
master destroy
|
||||
parent destroy
|
||||
} -result {foobar
|
||||
while executing
|
||||
"error foobar"
|
||||
@@ -2795,15 +2795,15 @@ test oo-18.8 {OO: define/self command support} -setup {
|
||||
invoked from within
|
||||
"oo::define foo {rename ::foo ::bar; self {error foobar}}"}
|
||||
test oo-18.9 {OO: define/self command support} -setup {
|
||||
oo::class create master
|
||||
oo::class create parent
|
||||
set c [oo::class create now_this_is_a_very_very_long_class_name_indeed {
|
||||
superclass master
|
||||
superclass parent
|
||||
}]
|
||||
} -body {
|
||||
catch {oo::define $c {error err}} msg opt
|
||||
dict get $opt -errorinfo
|
||||
} -cleanup {
|
||||
master destroy
|
||||
parent destroy
|
||||
} -result {err
|
||||
while executing
|
||||
"error err"
|
||||
@@ -2811,13 +2811,13 @@ test oo-18.9 {OO: define/self command support} -setup {
|
||||
invoked from within
|
||||
"oo::define $c {error err}"}
|
||||
test oo-18.10 {OO: define/self command support} -setup {
|
||||
oo::class create master
|
||||
oo::class create ::foo {superclass master}
|
||||
oo::class create parent
|
||||
oo::class create ::foo {superclass parent}
|
||||
} -body {
|
||||
catch {oo::define foo {self {rename ::foo {}; error foobar}}} msg opt
|
||||
dict get $opt -errorinfo
|
||||
} -cleanup {
|
||||
master destroy
|
||||
parent destroy
|
||||
} -result {foobar
|
||||
while executing
|
||||
"error foobar"
|
||||
@@ -2828,13 +2828,13 @@ test oo-18.10 {OO: define/self command support} -setup {
|
||||
invoked from within
|
||||
"oo::define foo {self {rename ::foo {}; error foobar}}"}
|
||||
test oo-18.11 {OO: define/self command support} -setup {
|
||||
oo::class create master
|
||||
oo::class create ::foo {superclass master}
|
||||
oo::class create parent
|
||||
oo::class create ::foo {superclass parent}
|
||||
} -body {
|
||||
catch {oo::define foo {rename ::foo {}; self {error foobar}}} msg opt
|
||||
dict get $opt -errorinfo
|
||||
} -cleanup {
|
||||
master destroy
|
||||
parent destroy
|
||||
} -result {this command cannot be called when the object has been deleted
|
||||
while executing
|
||||
"self {error foobar}"
|
||||
@@ -3457,12 +3457,12 @@ test oo-27.2 {variables declaration - object introspection} -setup {
|
||||
info object variables foo
|
||||
} -result {a b c}
|
||||
test oo-27.3 {variables declaration - basic behaviour} -setup {
|
||||
oo::class create master
|
||||
oo::class create parent
|
||||
} -cleanup {
|
||||
master destroy
|
||||
parent destroy
|
||||
} -body {
|
||||
oo::class create foo {
|
||||
superclass master
|
||||
superclass parent
|
||||
variable x!
|
||||
constructor {} {set x! 1}
|
||||
method y {} {incr x!}
|
||||
@@ -3472,13 +3472,13 @@ test oo-27.3 {variables declaration - basic behaviour} -setup {
|
||||
bar y
|
||||
} -result 3
|
||||
test oo-27.4 {variables declaration - destructors too} -setup {
|
||||
oo::class create master
|
||||
oo::class create parent
|
||||
set result bad!
|
||||
} -cleanup {
|
||||
master destroy
|
||||
parent destroy
|
||||
} -body {
|
||||
oo::class create foo {
|
||||
superclass master
|
||||
superclass parent
|
||||
variable x!
|
||||
constructor {} {set x! 1}
|
||||
method y {} {incr x!}
|
||||
@@ -3503,12 +3503,12 @@ test oo-27.5 {variables declaration - object-bound variables} -setup {
|
||||
foo y
|
||||
} -result 2
|
||||
test oo-27.6 {variables declaration - non-interference of levels} -setup {
|
||||
oo::class create master
|
||||
oo::class create parent
|
||||
} -cleanup {
|
||||
master destroy
|
||||
parent destroy
|
||||
} -body {
|
||||
oo::class create foo {
|
||||
superclass master
|
||||
superclass parent
|
||||
variable x!
|
||||
constructor {} {set x! 1}
|
||||
method y {} {incr x!}
|
||||
@@ -3523,12 +3523,12 @@ test oo-27.6 {variables declaration - non-interference of levels} -setup {
|
||||
list [bar y] [lsort [info object vars bar]] [bar eval {info vars *!}]
|
||||
} -result {{3 2 y! {}} {x! y!} {x! y!}}
|
||||
test oo-27.7 {variables declaration - one underlying variable space} -setup {
|
||||
oo::class create master
|
||||
oo::class create parent
|
||||
} -cleanup {
|
||||
master destroy
|
||||
parent destroy
|
||||
} -body {
|
||||
oo::class create foo {
|
||||
superclass master
|
||||
superclass parent
|
||||
variable x!
|
||||
constructor {} {set x! 1}
|
||||
method y {} {incr x!}
|
||||
@@ -3555,12 +3555,12 @@ test oo-27.9 {variables declaration - error cases - arrays} -body {
|
||||
oo::define oo::object variable bad(var)
|
||||
} -returnCodes error -result {invalid declared variable name "bad(var)": must not refer to an array element}
|
||||
test oo-27.10 {variables declaration - no instance var leaks with class resolvers} -setup {
|
||||
oo::class create master
|
||||
oo::class create parent
|
||||
} -cleanup {
|
||||
master destroy
|
||||
parent destroy
|
||||
} -body {
|
||||
oo::class create foo {
|
||||
superclass master
|
||||
superclass parent
|
||||
variable clsvar
|
||||
constructor {} {
|
||||
set clsvar 0
|
||||
@@ -3583,12 +3583,12 @@ test oo-27.10 {variables declaration - no instance var leaks with class resolver
|
||||
list [inst1 value] [inst2 value]
|
||||
} -result {3 2}
|
||||
test oo-27.11 {variables declaration - no instance var leaks with class resolvers} -setup {
|
||||
oo::class create master
|
||||
oo::class create parent
|
||||
} -cleanup {
|
||||
master destroy
|
||||
parent destroy
|
||||
} -body {
|
||||
oo::class create foo {
|
||||
superclass master
|
||||
superclass parent
|
||||
variable clsvar
|
||||
constructor {} {
|
||||
set clsvar 0
|
||||
@@ -3656,12 +3656,12 @@ test oo-27.13 {variables declaration: Bug 3185009: require refcount management}
|
||||
foo destroy
|
||||
} -result {0 7 1 7 {} 0 1 {can't read "x": no such variable}}
|
||||
test oo-27.14 {variables declaration - multiple use} -setup {
|
||||
oo::class create master
|
||||
oo::class create parent
|
||||
} -cleanup {
|
||||
master destroy
|
||||
parent destroy
|
||||
} -body {
|
||||
oo::class create foo {
|
||||
superclass master
|
||||
superclass parent
|
||||
variable x
|
||||
variable y
|
||||
method boo {} {
|
||||
@@ -3672,12 +3672,12 @@ test oo-27.14 {variables declaration - multiple use} -setup {
|
||||
list [bar boo] [bar boo]
|
||||
} -result {1,1 2,2}
|
||||
test oo-27.15 {variables declaration - multiple use} -setup {
|
||||
oo::class create master
|
||||
oo::class create parent
|
||||
} -cleanup {
|
||||
master destroy
|
||||
parent destroy
|
||||
} -body {
|
||||
oo::class create foo {
|
||||
superclass master
|
||||
superclass parent
|
||||
variable
|
||||
variable x y
|
||||
method boo {} {
|
||||
@@ -3688,12 +3688,12 @@ test oo-27.15 {variables declaration - multiple use} -setup {
|
||||
list [bar boo] [bar boo]
|
||||
} -result {1,1 2,2}
|
||||
test oo-27.16 {variables declaration - multiple use} -setup {
|
||||
oo::class create master
|
||||
oo::class create parent
|
||||
} -cleanup {
|
||||
master destroy
|
||||
parent destroy
|
||||
} -body {
|
||||
oo::class create foo {
|
||||
superclass master
|
||||
superclass parent
|
||||
variable x
|
||||
variable -clear
|
||||
variable y
|
||||
@@ -3705,12 +3705,12 @@ test oo-27.16 {variables declaration - multiple use} -setup {
|
||||
list [bar boo] [bar boo]
|
||||
} -result {1,1 1,2}
|
||||
test oo-27.17 {variables declaration - multiple use} -setup {
|
||||
oo::class create master
|
||||
oo::class create parent
|
||||
} -cleanup {
|
||||
master destroy
|
||||
parent destroy
|
||||
} -body {
|
||||
oo::class create foo {
|
||||
superclass master
|
||||
superclass parent
|
||||
variable x
|
||||
variable -set y
|
||||
method boo {} {
|
||||
@@ -3721,12 +3721,12 @@ test oo-27.17 {variables declaration - multiple use} -setup {
|
||||
list [bar boo] [bar boo]
|
||||
} -result {1,1 1,2}
|
||||
test oo-27.18 {variables declaration - multiple use} -setup {
|
||||
oo::class create master
|
||||
oo::class create parent
|
||||
} -cleanup {
|
||||
master destroy
|
||||
parent destroy
|
||||
} -body {
|
||||
oo::class create foo {
|
||||
superclass master
|
||||
superclass parent
|
||||
variable x
|
||||
variable -? y
|
||||
method boo {} {
|
||||
@@ -3824,12 +3824,12 @@ test oo-27.22 {variables declaration uniqueifies: Bug 3396896} -setup {
|
||||
} -result {v t}
|
||||
test oo-27.23 {variable resolver leakage: Bug 1493a43044} -setup {
|
||||
oo::class create Super
|
||||
oo::class create Master {
|
||||
oo::class create Parent {
|
||||
superclass Super
|
||||
variable member1 member2
|
||||
constructor {} {
|
||||
set member1 master1
|
||||
set member2 master2
|
||||
set member1 parent1
|
||||
set member2 parent2
|
||||
}
|
||||
method getChild {} {
|
||||
Child new [self]
|
||||
@@ -3850,10 +3850,10 @@ test oo-27.23 {variable resolver leakage: Bug 1493a43044} -setup {
|
||||
method result {} {return $result}
|
||||
}
|
||||
} -body {
|
||||
[[Master new] getChild] result
|
||||
[[Parent new] getChild] result
|
||||
} -cleanup {
|
||||
Super destroy
|
||||
} -result {master1 master2 master1 master2 master1 master2 master1 master2}
|
||||
} -result {parent1 parent2 parent1 parent2 parent1 parent2 parent1 parent2}
|
||||
|
||||
# A feature that's not supported because the mechanism may change without
|
||||
# warning, but is supposed to work...
|
||||
|
||||
+4
-4
@@ -882,9 +882,9 @@ test oo-call-3.4 {current call introspection: in destructors} -setup {
|
||||
# caller
|
||||
set testopts {
|
||||
-setup {
|
||||
oo::class create Master
|
||||
oo::class create Parent
|
||||
oo::class create Foo {
|
||||
superclass Master
|
||||
superclass Parent
|
||||
method bar {} {
|
||||
puts abc
|
||||
tailcall puts hi
|
||||
@@ -892,11 +892,11 @@ set testopts {
|
||||
}
|
||||
}
|
||||
oo::class create Foo2 {
|
||||
superclass Master
|
||||
superclass Parent
|
||||
}
|
||||
}
|
||||
-cleanup {
|
||||
Master destroy
|
||||
Parent destroy
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
+9
-9
@@ -405,14 +405,14 @@ test parse-8.11 {Tcl_EvalObjv procedure, TCL_EVAL_INVOKE} testevalobjv {
|
||||
proc ::unknown args {lappend ::info [info level]; uplevel 1 foo}
|
||||
proc ::foo args {lappend ::info global}
|
||||
catch {rename ::noSuchCommand {}}
|
||||
set ::slave [interp create]
|
||||
$::slave alias bar noSuchCommand
|
||||
set ::child [interp create]
|
||||
$::child alias bar noSuchCommand
|
||||
set ::info {}
|
||||
namespace eval test_ns_1 {
|
||||
proc foo args {lappend ::info namespace}
|
||||
$::slave eval bar
|
||||
testevalobjv 1 [list $::slave eval bar]
|
||||
uplevel #0 [list $::slave eval bar]
|
||||
$::child eval bar
|
||||
testevalobjv 1 [list $::child eval bar]
|
||||
uplevel #0 [list $::child eval bar]
|
||||
}
|
||||
namespace delete test_ns_1
|
||||
rename ::foo {}
|
||||
@@ -429,14 +429,14 @@ test parse-8.12 {Tcl_EvalObjv procedure, TCL_EVAL_INVOKE} {
|
||||
lappend ::info ns
|
||||
}]
|
||||
catch {rename ::noSuchCommand {}}
|
||||
set ::slave [interp create]
|
||||
$::slave alias bar noSuchCommand
|
||||
set ::child [interp create]
|
||||
$::child alias bar noSuchCommand
|
||||
set ::info {}
|
||||
namespace eval test_ns_1 {
|
||||
$::slave eval bar
|
||||
$::child eval bar
|
||||
}
|
||||
namespace delete test_ns_1
|
||||
interp delete $::slave
|
||||
interp delete $::child
|
||||
catch {rename ::noSuchCommand {}}
|
||||
set ::info
|
||||
} global
|
||||
|
||||
+11
-11
@@ -72,11 +72,11 @@ proc pkgtest::parseArgs { args } {
|
||||
# of the command line.
|
||||
|
||||
proc pkgtest::parseIndex { filePath } {
|
||||
# create a slave interpreter, where we override "package ifneeded"
|
||||
# create a child interpreter, where we override "package ifneeded"
|
||||
|
||||
set slave [interp create]
|
||||
set child [interp create]
|
||||
if {[catch {
|
||||
$slave eval {
|
||||
$child eval {
|
||||
rename package package_original
|
||||
proc package { args } {
|
||||
if {[lindex $args 0] eq "ifneeded"} {
|
||||
@@ -91,17 +91,17 @@ proc pkgtest::parseIndex { filePath } {
|
||||
}
|
||||
|
||||
set dir [file dirname $filePath]
|
||||
$slave eval {set curdir [pwd]}
|
||||
$slave eval [list cd $dir]
|
||||
$slave eval [list set dir $dir]
|
||||
$slave eval [list source [file tail $filePath]]
|
||||
$slave eval {cd $curdir}
|
||||
$child eval {set curdir [pwd]}
|
||||
$child eval [list cd $dir]
|
||||
$child eval [list set dir $dir]
|
||||
$child eval [list source [file tail $filePath]]
|
||||
$child eval {cd $curdir}
|
||||
|
||||
# Create the list in sorted order, so that we don't get spurious
|
||||
# errors because the order has changed.
|
||||
|
||||
array set P {}
|
||||
foreach {k v} [$slave eval {array get ::PKGS}] {
|
||||
foreach {k v} [$child eval {array get ::PKGS}] {
|
||||
set P($k) $v
|
||||
}
|
||||
|
||||
@@ -113,12 +113,12 @@ proc pkgtest::parseIndex { filePath } {
|
||||
set ei [dict get $opts -errorinfo]
|
||||
set ec [dict get $opts -errorcode]
|
||||
|
||||
catch {interp delete $slave}
|
||||
catch {interp delete $child}
|
||||
|
||||
error $ei $ec
|
||||
}
|
||||
|
||||
interp delete $slave
|
||||
interp delete $child
|
||||
|
||||
return $PKGS
|
||||
}
|
||||
|
||||
+3
-3
@@ -389,9 +389,9 @@ test proc-7.3 {Returning loop exception from redefined cmd: Bug 729692} -body {
|
||||
test proc-7.4 {Proc struct outlives its interp: Bug 3532959} {
|
||||
set lambda x
|
||||
lappend lambda {set a 1}
|
||||
interp create slave
|
||||
slave eval [list apply $lambda foo]
|
||||
interp delete slave
|
||||
interp create child
|
||||
child eval [list apply $lambda foo]
|
||||
interp delete child
|
||||
unset lambda
|
||||
} {}
|
||||
|
||||
|
||||
+1
-1
@@ -203,7 +203,7 @@ test resolver-2.1 {compiled var resolver: Bug #3383616} -setup {
|
||||
# resolver-agnostic).
|
||||
#
|
||||
# In order to make the test cases for the per-interpreter cmd literal pool
|
||||
# reproducable and to minimize interactions between test cases, we use a slave
|
||||
# reproducable and to minimize interactions between test cases, we use a child
|
||||
# interpreter per test-case.
|
||||
#
|
||||
#
|
||||
|
||||
+14
-14
@@ -17,7 +17,7 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
namespace import -force ::tcltest::*
|
||||
}
|
||||
|
||||
foreach i [interp slaves] {
|
||||
foreach i [interp children] {
|
||||
interp delete $i
|
||||
}
|
||||
|
||||
@@ -35,16 +35,16 @@ testConstraint TcltestPackage [expr {![catch {package require Tcltest}]}]
|
||||
|
||||
test safe-1.1 {safe::interpConfigure syntax} -returnCodes error -body {
|
||||
safe::interpConfigure
|
||||
} -result {no value given for parameter "slave" (use -help for full usage) :
|
||||
slave name () name of the slave}
|
||||
} -result {no value given for parameter "child" (use -help for full usage) :
|
||||
child name () name of the child}
|
||||
test safe-1.2 {safe::interpCreate syntax} -returnCodes error -body {
|
||||
safe::interpCreate -help
|
||||
} -result {Usage information:
|
||||
Var/FlagName Type Value Help
|
||||
------------ ---- ----- ----
|
||||
(-help gives this help)
|
||||
?slave? name () name of the slave (optional)
|
||||
-accessPath list () access path for the slave
|
||||
?child? name () name of the child (optional)
|
||||
-accessPath list () access path for the child
|
||||
-noStatics boolflag (false) prevent loading of statically linked pkgs
|
||||
-statics boolean (true) loading of statically linked pkgs
|
||||
-nestedLoadOk boolflag (false) allow nested loading
|
||||
@@ -53,7 +53,7 @@ test safe-1.2 {safe::interpCreate syntax} -returnCodes error -body {
|
||||
test safe-1.3 {safe::interpInit syntax} -returnCodes error -body {
|
||||
safe::interpInit -noStatics
|
||||
} -result {bad value "-noStatics" for parameter
|
||||
slave name () name of the slave}
|
||||
child name () name of the child}
|
||||
|
||||
test safe-2.1 {creating interpreters, should have no aliases} emptyTest {
|
||||
# Disabled this test. It tests nothing sensible. [Bug 999612]
|
||||
@@ -184,7 +184,7 @@ test safe-7.1 {tests that everything works at high level} -body {
|
||||
set i [safe::interpCreate]
|
||||
# no error shall occur:
|
||||
# (because the default access_path shall include 1st level sub dirs so
|
||||
# package require in a slave works like in the master)
|
||||
# package require in a child works like in the parent)
|
||||
set v [interp eval $i {package require http 2}]
|
||||
# no error shall occur:
|
||||
interp eval $i {http::config}
|
||||
@@ -241,7 +241,7 @@ test safe-8.3 {safe source control on file} -setup {
|
||||
safe::setLogCmd $prevlog
|
||||
unset log
|
||||
safe::interpDelete $i
|
||||
} -result {1 {permission denied} {{ERROR for slave a : ".": is a directory}}}
|
||||
} -result {1 {permission denied} {{ERROR for child a : ".": is a directory}}}
|
||||
test safe-8.4 {safe source control on file} -setup {
|
||||
catch {safe::interpDelete $i}
|
||||
set log {}
|
||||
@@ -255,7 +255,7 @@ test safe-8.4 {safe source control on file} -setup {
|
||||
safe::setLogCmd $prevlog
|
||||
unset log
|
||||
safe::interpDelete $i
|
||||
} -result {1 {permission denied} {{ERROR for slave a : "/abc/def": not in access_path}}}
|
||||
} -result {1 {permission denied} {{ERROR for child a : "/abc/def": not in access_path}}}
|
||||
test safe-8.5 {safe source control on file} -setup {
|
||||
catch {safe::interpDelete $i}
|
||||
set log {}
|
||||
@@ -273,7 +273,7 @@ test safe-8.5 {safe source control on file} -setup {
|
||||
safe::setLogCmd $prevlog
|
||||
unset log
|
||||
safe::interpDelete $i
|
||||
} -result [list 1 {no such file or directory} [list "ERROR for slave a : [file join [info library] blah]:no such file or directory"]]
|
||||
} -result [list 1 {no such file or directory} [list "ERROR for child a : [file join [info library] blah]:no such file or directory"]]
|
||||
test safe-8.6 {safe source control on file} -setup {
|
||||
catch {safe::interpDelete $i}
|
||||
set log {}
|
||||
@@ -289,7 +289,7 @@ test safe-8.6 {safe source control on file} -setup {
|
||||
safe::setLogCmd $prevlog
|
||||
unset log
|
||||
safe::interpDelete $i
|
||||
} -result [list 1 {no such file or directory} [list "ERROR for slave a : [file join [info library] blah.tcl]:no such file or directory"]]
|
||||
} -result [list 1 {no such file or directory} [list "ERROR for child a : [file join [info library] blah.tcl]:no such file or directory"]]
|
||||
test safe-8.7 {safe source control on file} -setup {
|
||||
catch {safe::interpDelete $i}
|
||||
set log {}
|
||||
@@ -307,7 +307,7 @@ test safe-8.7 {safe source control on file} -setup {
|
||||
safe::setLogCmd $prevlog
|
||||
unset log
|
||||
safe::interpDelete $i
|
||||
} -result [list 1 {no such file or directory} [list "ERROR for slave a : [file join [info library] xxxxxxxxxxx.tcl]:no such file or directory"]]
|
||||
} -result [list 1 {no such file or directory} [list "ERROR for child a : [file join [info library] xxxxxxxxxxx.tcl]:no such file or directory"]]
|
||||
test safe-8.8 {safe source forbids -rsrc} emptyTest {
|
||||
# Disabled this test. It was only useful for long unsupported
|
||||
# Mac OS 9 systems. [Bug 860a9f1945]
|
||||
@@ -375,7 +375,7 @@ test safe-9.2 {safe interps' error in deleteHook} -setup {
|
||||
} -cleanup {
|
||||
safe::setLogCmd $prevlog
|
||||
unset log
|
||||
} -result {{} {arg1 arg2 a} {{NOTICE for slave a : About to delete} {ERROR for slave a : Delete hook error (being catched)} {NOTICE for slave a : Deleted}}}
|
||||
} -result {{} {arg1 arg2 a} {{NOTICE for child a : About to delete} {ERROR for child a : Delete hook error (being catched)} {NOTICE for child a : Deleted}}}
|
||||
test safe-9.3 {dual specification of statics} -returnCodes error -body {
|
||||
safe::interpCreate -stat true -nostat
|
||||
} -result {conflicting values given for -statics and -noStatics}
|
||||
@@ -737,7 +737,7 @@ test safe-13.10 {as 13.8 but test silent failure when result is outside access_p
|
||||
rename buildEnvironment {}
|
||||
|
||||
#### Test for the module path
|
||||
test safe-14.1 {Check that module path is the same as in the master interpreter [Bug 2964715]} -setup {
|
||||
test safe-14.1 {Check that module path is the same as in the parent interpreter [Bug 2964715]} -setup {
|
||||
set i [safe::interpCreate]
|
||||
} -body {
|
||||
set tm {}
|
||||
|
||||
+15
-15
@@ -1835,12 +1835,12 @@ proc transf_test {{testmode transfer} {maxIter 1000} {maxTime 10000}} {
|
||||
}
|
||||
}
|
||||
tcltest::DebugPuts 1 "== test \[$::localhost\]:$port $testmode =="
|
||||
set ::master [thread::id]
|
||||
# helper thread creating async connection and initiating transfer (detach) to master:
|
||||
set ::parent [thread::id]
|
||||
# helper thread creating async connection and initiating transfer (detach) to parent:
|
||||
set ::helper [thread::create]
|
||||
thread::send -async $::helper [list \
|
||||
lassign [list $::master $::localhost $port $testmode] \
|
||||
::master ::localhost ::port ::testmode
|
||||
lassign [list $::parent $::localhost $port $testmode] \
|
||||
::parent ::localhost ::port ::testmode
|
||||
]
|
||||
thread::send -async $::helper {
|
||||
set ::helper [thread::id]
|
||||
@@ -1849,29 +1849,29 @@ proc transf_test {{testmode transfer} {maxIter 1000} {maxTime 10000}} {
|
||||
if {"helper-writable" in $::testmode} {;# to test both sides during connect
|
||||
fileevent $fd writable [list apply {{fd} {
|
||||
if {[thread::id] ne $::helper} {
|
||||
thread::send -async $::master {set ::count "ERROR: invalid thread, $::helper is expecting"}
|
||||
thread::send -async $::parent {set ::count "ERROR: invalid thread, $::helper is expecting"}
|
||||
close $fd
|
||||
return
|
||||
}
|
||||
}} $fd]
|
||||
};#
|
||||
thread::detach $fd
|
||||
thread::send -async $::master [list transf_master $fd {*}$args]
|
||||
thread::send -async $::parent [list transf_parent $fd {*}$args]
|
||||
}
|
||||
iteration first
|
||||
}
|
||||
# master proc commiting transfer attempt (attach) and checking acquire was successful:
|
||||
proc transf_master {fd args} {
|
||||
# parent proc commiting transfer attempt (attach) and checking acquire was successful:
|
||||
proc transf_parent {fd args} {
|
||||
tcltest::DebugPuts 1 "** trma / $::count ** $args **"
|
||||
thread::attach $fd
|
||||
if {"master-close" in $::testmode} {;# to test close during connect
|
||||
if {"parent-close" in $::testmode} {;# to test close during connect
|
||||
set ::count $::count
|
||||
close $fd
|
||||
return
|
||||
};#
|
||||
fileevent $fd writable [list apply {{fd} {
|
||||
if {[thread::id] ne $::master} {
|
||||
thread::send -async $::master {set ::count "ERROR: invalid thread, $::master is expecting"}
|
||||
if {[thread::id] ne $::parent} {
|
||||
thread::send -async $::parent {set ::count "ERROR: invalid thread, $::parent is expecting"}
|
||||
close $fd
|
||||
return
|
||||
}
|
||||
@@ -1899,7 +1899,7 @@ proc transf_test {{testmode transfer} {maxIter 1000} {maxTime 10000}} {
|
||||
if {$srvsock ne {}} {close $srvsock}
|
||||
if {[info exists ::helper]} {thread::release -wait $::helper}
|
||||
tcltest::DebugPuts 1 "== stop / $::count =="
|
||||
unset -nocomplain ::count ::testmode ::master ::helper
|
||||
unset -nocomplain ::count ::testmode ::parent ::helper
|
||||
}
|
||||
}
|
||||
test socket_$af-13.2.tr1 {Testing socket transfer between threads during async connect} -body {
|
||||
@@ -1909,12 +1909,12 @@ test socket_$af-13.2.tr2 {Testing socket transfer between threads during async c
|
||||
transf_test {transfer helper-writable} 100
|
||||
} -result 100 -constraints [list socket supported_$af thread]
|
||||
test socket_$af-13.2.cl1 {Testing socket transfer between threads during async connect} -body {
|
||||
transf_test {master-close} 100
|
||||
transf_test {parent-close} 100
|
||||
} -result 100 -constraints [list socket supported_$af thread]
|
||||
test socket_$af-13.2.cl2 {Testing socket transfer between threads during async connect} -body {
|
||||
transf_test {master-close helper-writable} 100
|
||||
transf_test {parent-close helper-writable} 100
|
||||
} -result 100 -constraints [list socket supported_$af thread]
|
||||
catch {rename transf_master {}}
|
||||
catch {rename transf_parent {}}
|
||||
rename transf_test {}
|
||||
|
||||
# ----------------------------------------------------------------------
|
||||
|
||||
+7
-7
@@ -282,18 +282,18 @@ test subst-13.1 {Bug 3081065} -setup {
|
||||
demo name2
|
||||
} subst13.tcl]
|
||||
} -body {
|
||||
interp create slave
|
||||
slave eval [list source $script]
|
||||
interp delete slave
|
||||
interp create slave
|
||||
slave eval {
|
||||
interp create child
|
||||
child eval [list source $script]
|
||||
interp delete child
|
||||
interp create child
|
||||
child eval {
|
||||
set count 400
|
||||
while {[incr count -1]} {
|
||||
lappend bloat [expr {rand()}]
|
||||
}
|
||||
}
|
||||
slave eval [list source $script]
|
||||
interp delete slave
|
||||
child eval [list source $script]
|
||||
interp delete child
|
||||
} -cleanup {
|
||||
removeFile subst13.tcl
|
||||
}
|
||||
|
||||
+68
-68
@@ -13,7 +13,7 @@
|
||||
# testing to run the test itself. Ditto on things like [verbose].
|
||||
#
|
||||
# It would be better to have the -body of the tests run the tcltest
|
||||
# commands in a slave interp so the [test] being tested would not
|
||||
# commands in a child interp so the [test] being tested would not
|
||||
# interfere with the [test] doing the testing.
|
||||
#
|
||||
|
||||
@@ -63,11 +63,11 @@ test tcltest-1.3 {tcltest -h} {exec} {
|
||||
} {1 0}
|
||||
|
||||
# -verbose, implicit & explicit testing of [verbose]
|
||||
proc slave {msgVar args} {
|
||||
proc child {msgVar args} {
|
||||
upvar 1 $msgVar msg
|
||||
|
||||
interp create [namespace current]::i
|
||||
# Fake the slave interp into dumping output to a file
|
||||
# Fake the child interp into dumping output to a file
|
||||
i eval {namespace eval ::tcltest {}}
|
||||
i eval "set tcltest::outputChannel\
|
||||
\[[list open [set of [makeFile {} output]] w]]"
|
||||
@@ -99,44 +99,44 @@ proc slave {msgVar args} {
|
||||
return $code
|
||||
}
|
||||
test tcltest-2.0 {tcltest (verbose default - 'b')} {unixOrWin} {
|
||||
set result [slave msg test.tcl]
|
||||
set result [child msg test.tcl]
|
||||
list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
|
||||
[regexp c-1.0 $msg] \
|
||||
[regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
|
||||
} {0 1 0 0 1}
|
||||
test tcltest-2.1 {tcltest -verbose 'b'} {unixOrWin} {
|
||||
set result [slave msg test.tcl -verbose 'b']
|
||||
set result [child msg test.tcl -verbose 'b']
|
||||
list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
|
||||
[regexp c-1.0 $msg] \
|
||||
[regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
|
||||
} {0 1 0 0 1}
|
||||
test tcltest-2.2 {tcltest -verbose 'p'} {unixOrWin} {
|
||||
set result [slave msg test.tcl -verbose 'p']
|
||||
set result [child msg test.tcl -verbose 'p']
|
||||
list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
|
||||
[regexp c-1.0 $msg] \
|
||||
[regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
|
||||
} {0 0 1 0 1}
|
||||
test tcltest-2.3 {tcltest -verbose 's'} {unixOrWin} {
|
||||
set result [slave msg test.tcl -verbose 's']
|
||||
set result [child msg test.tcl -verbose 's']
|
||||
list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
|
||||
[regexp c-1.0 $msg] \
|
||||
[regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
|
||||
} {0 0 0 1 1}
|
||||
test tcltest-2.4 {tcltest -verbose 'ps'} {unixOrWin} {
|
||||
set result [slave msg test.tcl -verbose 'ps']
|
||||
set result [child msg test.tcl -verbose 'ps']
|
||||
list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
|
||||
[regexp c-1.0 $msg] \
|
||||
[regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
|
||||
} {0 0 1 1 1}
|
||||
test tcltest-2.5 {tcltest -verbose 'psb'} {unixOrWin} {
|
||||
set result [slave msg test.tcl -verbose 'psb']
|
||||
set result [child msg test.tcl -verbose 'psb']
|
||||
list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
|
||||
[regexp c-1.0 $msg] \
|
||||
[regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
|
||||
} {0 1 1 1 1}
|
||||
|
||||
test tcltest-2.5a {tcltest -verbose 'pass skip body'} {unixOrWin} {
|
||||
set result [slave msg test.tcl -verbose "pass skip body"]
|
||||
set result [child msg test.tcl -verbose "pass skip body"]
|
||||
list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
|
||||
[regexp c-1.0 $msg] \
|
||||
[regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
|
||||
@@ -145,7 +145,7 @@ test tcltest-2.5a {tcltest -verbose 'pass skip body'} {unixOrWin} {
|
||||
test tcltest-2.6 {tcltest -verbose 't'} {
|
||||
-constraints {unixOrWin}
|
||||
-body {
|
||||
set result [slave msg test.tcl -verbose 't']
|
||||
set result [child msg test.tcl -verbose 't']
|
||||
list $result $msg
|
||||
}
|
||||
-result {^0 .*a-1.0 start.*b-1.0 start}
|
||||
@@ -155,7 +155,7 @@ test tcltest-2.6 {tcltest -verbose 't'} {
|
||||
test tcltest-2.6a {tcltest -verbose 'start'} {
|
||||
-constraints {unixOrWin}
|
||||
-body {
|
||||
set result [slave msg test.tcl -verbose start]
|
||||
set result [child msg test.tcl -verbose start]
|
||||
list $result $msg
|
||||
}
|
||||
-result {^0 .*a-1.0 start.*b-1.0 start}
|
||||
@@ -178,7 +178,7 @@ test tcltest-2.7 {tcltest::verbose} {
|
||||
test tcltest-2.8 {tcltest -verbose 'error'} {
|
||||
-constraints {unixOrWin}
|
||||
-body {
|
||||
set result [slave msg test.tcl -verbose error]
|
||||
set result [child msg test.tcl -verbose error]
|
||||
list $result $msg
|
||||
}
|
||||
-result {errorInfo: foo.*errorCode: 9}
|
||||
@@ -186,22 +186,22 @@ test tcltest-2.8 {tcltest -verbose 'error'} {
|
||||
}
|
||||
# -match, [match]
|
||||
test tcltest-3.1 {tcltest -match 'a*'} {unixOrWin} {
|
||||
set result [slave msg test.tcl -match a* -verbose 'ps']
|
||||
set result [child msg test.tcl -match a* -verbose 'ps']
|
||||
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
|
||||
[regexp "Total.+4.+Passed.+1.+Skipped.+3.+Failed.+0" $msg]
|
||||
} {0 1 0 0 1}
|
||||
test tcltest-3.2 {tcltest -match 'b*'} {unixOrWin} {
|
||||
set result [slave msg test.tcl -match b* -verbose 'ps']
|
||||
set result [child msg test.tcl -match b* -verbose 'ps']
|
||||
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
|
||||
[regexp "Total.+4.+Passed.+0.+Skipped.+3.+Failed.+1" $msg]
|
||||
} {0 0 1 0 1}
|
||||
test tcltest-3.3 {tcltest -match 'c*'} {unixOrWin} {
|
||||
set result [slave msg test.tcl -match c* -verbose 'ps']
|
||||
set result [child msg test.tcl -match c* -verbose 'ps']
|
||||
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
|
||||
[regexp "Total.+4.+Passed.+0.+Skipped.+4.+Failed.+0" $msg]
|
||||
} {0 0 0 1 1}
|
||||
test tcltest-3.4 {tcltest -match 'a* b*'} {unixOrWin} {
|
||||
set result [slave msg test.tcl -match {a* b*} -verbose 'ps']
|
||||
set result [child msg test.tcl -match {a* b*} -verbose 'ps']
|
||||
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
|
||||
[regexp "Total.+4.+Passed.+1.+Skipped.+2.+Failed.+1" $msg]
|
||||
} {0 1 1 0 1}
|
||||
@@ -221,27 +221,27 @@ test tcltest-3.5 {tcltest::match} {
|
||||
|
||||
# -skip, [skip]
|
||||
test tcltest-4.1 {tcltest -skip 'a*'} {unixOrWin} {
|
||||
set result [slave msg test.tcl -skip a* -verbose 'ps']
|
||||
set result [child msg test.tcl -skip a* -verbose 'ps']
|
||||
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
|
||||
[regexp "Total.+4.+Passed.+0.+Skipped.+2.+Failed.+1" $msg]
|
||||
} {0 0 1 1 1}
|
||||
test tcltest-4.2 {tcltest -skip 'b*'} {unixOrWin} {
|
||||
set result [slave msg test.tcl -skip b* -verbose 'ps']
|
||||
set result [child msg test.tcl -skip b* -verbose 'ps']
|
||||
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
|
||||
[regexp "Total.+4.+Passed.+1.+Skipped.+2.+Failed.+1" $msg]
|
||||
} {0 1 0 1 1}
|
||||
test tcltest-4.3 {tcltest -skip 'c*'} {unixOrWin} {
|
||||
set result [slave msg test.tcl -skip c* -verbose 'ps']
|
||||
set result [child msg test.tcl -skip c* -verbose 'ps']
|
||||
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
|
||||
[regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
|
||||
} {0 1 1 0 1}
|
||||
test tcltest-4.4 {tcltest -skip 'a* b*'} {unixOrWin} {
|
||||
set result [slave msg test.tcl -skip {a* b*} -verbose 'ps']
|
||||
set result [child msg test.tcl -skip {a* b*} -verbose 'ps']
|
||||
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
|
||||
[regexp "Total.+4.+Passed.+0.+Skipped.+3.+Failed.+1" $msg]
|
||||
} {0 0 0 1 1}
|
||||
test tcltest-4.5 {tcltest -match 'a* b*' -skip 'b*'} {unixOrWin} {
|
||||
set result [slave msg test.tcl -match {a* b*} -skip b* -verbose 'ps']
|
||||
set result [child msg test.tcl -match {a* b*} -skip b* -verbose 'ps']
|
||||
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
|
||||
[regexp "Total.+4.+Passed.+1.+Skipped.+3.+Failed.+0" $msg]
|
||||
} {0 1 0 0 1}
|
||||
@@ -262,12 +262,12 @@ test tcltest-4.6 {tcltest::skip} {
|
||||
# -constraints, -limitconstraints, [testConstraint],
|
||||
# $constraintsSpecified, [limitConstraints]
|
||||
test tcltest-5.1 {tcltest -constraints 'knownBug'} {unixOrWin} {
|
||||
set result [slave msg test.tcl -constraints knownBug -verbose 'ps']
|
||||
set result [child msg test.tcl -constraints knownBug -verbose 'ps']
|
||||
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
|
||||
[regexp "Total.+4.+Passed.+2.+Skipped.+0.+Failed.+2" $msg]
|
||||
} {0 1 1 1 1}
|
||||
test tcltest-5.2 {tcltest -constraints 'knownBug' -limitconstraints 1} {unixOrWin} {
|
||||
set result [slave msg test.tcl -constraints knownBug -verbose 'p' -limitconstraints 1]
|
||||
set result [child msg test.tcl -constraints knownBug -verbose 'p' -limitconstraints 1]
|
||||
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
|
||||
[regexp "Total.+4.+Passed.+1.+Skipped.+3.+Failed.+0" $msg]
|
||||
} {0 0 0 1 1}
|
||||
@@ -357,28 +357,28 @@ set printerror [makeFile {
|
||||
test tcltest-6.1 {tcltest -outfile, -errfile defaults} {
|
||||
-constraints unixOrWin
|
||||
-body {
|
||||
slave msg $printerror
|
||||
child msg $printerror
|
||||
return $msg
|
||||
}
|
||||
-result {a test.*a really}
|
||||
-match regexp
|
||||
}
|
||||
test tcltest-6.2 {tcltest -outfile a.tmp} {unixOrWin unixExecs} {
|
||||
slave msg $printerror -outfile a.tmp
|
||||
child msg $printerror -outfile a.tmp
|
||||
set result1 [catch {exec grep "a test" a.tmp}]
|
||||
set result2 [catch {exec grep "a really" a.tmp}]
|
||||
list [regexp "a test" $msg] [regexp "a really" $msg] \
|
||||
$result1 $result2 [file exists a.tmp] [file delete a.tmp]
|
||||
} {0 1 0 1 1 {}}
|
||||
test tcltest-6.3 {tcltest -errfile a.tmp} {unixOrWin unixExecs} {
|
||||
slave msg $printerror -errfile a.tmp
|
||||
child msg $printerror -errfile a.tmp
|
||||
set result1 [catch {exec grep "a test" a.tmp}]
|
||||
set result2 [catch {exec grep "a really" a.tmp}]
|
||||
list [regexp "a test" $msg] [regexp "a really" $msg] \
|
||||
$result1 $result2 [file exists a.tmp] [file delete a.tmp]
|
||||
} {1 0 1 0 1 {}}
|
||||
test tcltest-6.4 {tcltest -outfile a.tmp -errfile b.tmp} {unixOrWin unixExecs} {
|
||||
slave msg $printerror -outfile a.tmp -errfile b.tmp
|
||||
child msg $printerror -outfile a.tmp -errfile b.tmp
|
||||
set result1 [catch {exec grep "a test" a.tmp}]
|
||||
set result2 [catch {exec grep "a really" b.tmp}]
|
||||
list [regexp "a test" $msg] [regexp "a really" $msg] \
|
||||
@@ -463,7 +463,7 @@ test tcltest-6.8 {tcltest::outputFile (implicit outputFile)} {
|
||||
# -debug, [debug]
|
||||
# Must use child processes to test -debug because it always writes
|
||||
# messages to stdout, and we have no way to capture stdout of a
|
||||
# slave interp
|
||||
# child interp
|
||||
test tcltest-7.1 {tcltest test.tcl -debug 0} {unixOrWin} {
|
||||
catch {exec [interpreter] test.tcl -debug 0} msg
|
||||
regexp "Flags passed into tcltest" $msg
|
||||
@@ -525,7 +525,7 @@ normalizePath normaldirectory
|
||||
test tcltest-8.1 {tcltest a.tcl -tmpdir a} -constraints unixOrWin -setup {
|
||||
file delete -force thisdirectorydoesnotexist
|
||||
} -body {
|
||||
slave msg $a -tmpdir thisdirectorydoesnotexist
|
||||
child msg $a -tmpdir thisdirectorydoesnotexist
|
||||
file exists [file join thisdirectorydoesnotexist a.tmp]
|
||||
} -cleanup {
|
||||
file delete -force thisdirectorydoesnotexist
|
||||
@@ -533,7 +533,7 @@ test tcltest-8.1 {tcltest a.tcl -tmpdir a} -constraints unixOrWin -setup {
|
||||
test tcltest-8.2 {tcltest a.tcl -tmpdir thisdirectoryisafile} {
|
||||
-constraints unixOrWin
|
||||
-body {
|
||||
slave msg $a -tmpdir $tdiaf
|
||||
child msg $a -tmpdir $tdiaf
|
||||
return $msg
|
||||
}
|
||||
-result {*not a directory*}
|
||||
@@ -558,7 +558,7 @@ switch -- $::tcl_platform(platform) {
|
||||
test tcltest-8.3 {tcltest a.tcl -tmpdir notReadableDir} {
|
||||
-constraints {unix notRoot}
|
||||
-body {
|
||||
slave msg $a -tmpdir $notReadableDir
|
||||
child msg $a -tmpdir $notReadableDir
|
||||
return $msg
|
||||
}
|
||||
-result {*not readable*}
|
||||
@@ -574,7 +574,7 @@ testConstraint notFAT [expr {
|
||||
test tcltest-8.4 {tcltest a.tcl -tmpdir notWriteableDir} {
|
||||
-constraints {unixOrWin notRoot notFAT}
|
||||
-body {
|
||||
slave msg $a -tmpdir $notWriteableDir
|
||||
child msg $a -tmpdir $notWriteableDir
|
||||
return $msg
|
||||
}
|
||||
-result {*not writeable*}
|
||||
@@ -583,7 +583,7 @@ test tcltest-8.4 {tcltest a.tcl -tmpdir notWriteableDir} {
|
||||
test tcltest-8.5 {tcltest a.tcl -tmpdir normaldirectory} {
|
||||
-constraints unixOrWin
|
||||
-body {
|
||||
slave msg $a -tmpdir $normaldirectory
|
||||
child msg $a -tmpdir $normaldirectory
|
||||
# The join is necessary because the message can be split on multiple
|
||||
# lines
|
||||
file exists [file join $normaldirectory a.tmp]
|
||||
@@ -629,7 +629,7 @@ test tcltest-8.10 {tcltest a.tcl -testdir thisdirectorydoesnotexist} {
|
||||
file delete -force thisdirectorydoesnotexist
|
||||
}
|
||||
-body {
|
||||
slave msg $a -testdir thisdirectorydoesnotexist
|
||||
child msg $a -testdir thisdirectorydoesnotexist
|
||||
return $msg
|
||||
}
|
||||
-match glob
|
||||
@@ -638,7 +638,7 @@ test tcltest-8.10 {tcltest a.tcl -testdir thisdirectorydoesnotexist} {
|
||||
test tcltest-8.11 {tcltest a.tcl -testdir thisdirectoryisafile} {
|
||||
-constraints unixOrWin
|
||||
-body {
|
||||
slave msg $a -testdir $tdiaf
|
||||
child msg $a -testdir $tdiaf
|
||||
return $msg
|
||||
}
|
||||
-match glob
|
||||
@@ -647,7 +647,7 @@ test tcltest-8.11 {tcltest a.tcl -testdir thisdirectoryisafile} {
|
||||
test tcltest-8.12 {tcltest a.tcl -testdir notReadableDir} {
|
||||
-constraints {unix notRoot}
|
||||
-body {
|
||||
slave msg $a -testdir $notReadableDir
|
||||
child msg $a -testdir $notReadableDir
|
||||
return $msg
|
||||
}
|
||||
-match glob
|
||||
@@ -656,7 +656,7 @@ test tcltest-8.12 {tcltest a.tcl -testdir notReadableDir} {
|
||||
test tcltest-8.13 {tcltest a.tcl -testdir normaldirectory} {
|
||||
-constraints unixOrWin
|
||||
-body {
|
||||
slave msg $a -testdir $normaldirectory
|
||||
child msg $a -testdir $normaldirectory
|
||||
# The join is necessary because the message can be split on multiple
|
||||
# lines
|
||||
list [string first "testdir: $normaldirectory" [join $msg]] \
|
||||
@@ -735,7 +735,7 @@ test tcltest-9.1 {-file d*.tcl} -constraints {unixOrWin} -setup {
|
||||
set old [testsDirectory]
|
||||
testsDirectory [file dirname [info script]]
|
||||
} -body {
|
||||
slave msg [file join [testsDirectory] all.tcl] -file d*.test
|
||||
child msg [file join [testsDirectory] all.tcl] -file d*.test
|
||||
return $msg
|
||||
} -cleanup {
|
||||
testsDirectory $old
|
||||
@@ -745,7 +745,7 @@ test tcltest-9.2 {-file d*.tcl} -constraints {unixOrWin} -setup {
|
||||
set old [testsDirectory]
|
||||
testsDirectory [file dirname [info script]]
|
||||
} -body {
|
||||
slave msg [file join [testsDirectory] all.tcl] \
|
||||
child msg [file join [testsDirectory] all.tcl] \
|
||||
-file d*.test -notfile dstring*
|
||||
regexp {dstring\.test} $msg
|
||||
} -cleanup {
|
||||
@@ -784,7 +784,7 @@ test tcltest-9.5 {GetMatchingFiles: Bug 1119798} -setup {
|
||||
makeFile {} fee $d
|
||||
file copy [file join [file dirname [info script]] all.tcl] $d
|
||||
} -body {
|
||||
slave msg [file join [temporaryDirectory] all.tcl] -file f*
|
||||
child msg [file join [temporaryDirectory] all.tcl] -file f*
|
||||
regexp {exiting with errors:} $msg
|
||||
} -cleanup {
|
||||
file delete [file join $d all.tcl]
|
||||
@@ -807,23 +807,23 @@ set mc [makeFile {
|
||||
|
||||
cd [temporaryDirectory]
|
||||
test tcltest-10.1 {-preservecore 0} {unixOrWin} {
|
||||
slave msg $mc -preservecore 0
|
||||
child msg $mc -preservecore 0
|
||||
file delete core
|
||||
regexp "Core file produced" $msg
|
||||
} {0}
|
||||
test tcltest-10.2 {-preservecore 1} {unixOrWin} {
|
||||
slave msg $mc -preservecore 1
|
||||
child msg $mc -preservecore 1
|
||||
file delete core
|
||||
regexp "Core file produced" $msg
|
||||
} {1}
|
||||
test tcltest-10.3 {-preservecore 2} {unixOrWin} {
|
||||
slave msg $mc -preservecore 2
|
||||
child msg $mc -preservecore 2
|
||||
file delete core
|
||||
list [regexp "Core file produced" $msg] [regexp "Moving file to" $msg] \
|
||||
[regexp "core-" $msg] [file delete core-makecore]
|
||||
} {1 1 1 {}}
|
||||
test tcltest-10.4 {-preservecore 3} {unixOrWin} {
|
||||
slave msg $mc -preservecore 3
|
||||
child msg $mc -preservecore 3
|
||||
file delete core
|
||||
list [regexp "Core file produced" $msg] [regexp "Moving file to" $msg] \
|
||||
[regexp "core-" $msg] [file delete core-makecore]
|
||||
@@ -854,7 +854,7 @@ set contents {
|
||||
set loadfile [makeFile $contents load.tcl]
|
||||
|
||||
test tcltest-12.1 {-load xxx} {unixOrWin} {
|
||||
slave msg $loadfile -load xxx
|
||||
child msg $loadfile -load xxx
|
||||
return $msg
|
||||
} {xxx}
|
||||
|
||||
@@ -952,7 +952,7 @@ cd [workingDirectory]
|
||||
test tcltest-14.1 {-singleproc - single process} {
|
||||
-constraints {unixOrWin}
|
||||
-body {
|
||||
slave msg $allfile -singleproc 0 -tmpdir [temporaryDirectory]
|
||||
child msg $allfile -singleproc 0 -tmpdir [temporaryDirectory]
|
||||
return $msg
|
||||
}
|
||||
-result {Test file error: can't unset .foo.: no such variable}
|
||||
@@ -962,7 +962,7 @@ test tcltest-14.1 {-singleproc - single process} {
|
||||
test tcltest-14.2 {-singleproc - multiple process} {
|
||||
-constraints {unixOrWin}
|
||||
-body {
|
||||
slave msg $allfile -singleproc 1 -tmpdir [temporaryDirectory]
|
||||
child msg $allfile -singleproc 1 -tmpdir [temporaryDirectory]
|
||||
return $msg
|
||||
}
|
||||
-result {single1.test.*single2.test.*all\-single.tcl:.*Total.*0.*Passed.*0.*Skipped.*0.*Failed.*0}
|
||||
@@ -1026,7 +1026,7 @@ makeFile {
|
||||
test tcltest-15.1 {basic directory walking} {
|
||||
-constraints {unixOrWin}
|
||||
-body {
|
||||
if {[slave msg \
|
||||
if {[child msg \
|
||||
[file join $dtd all.tcl] \
|
||||
-tmpdir [temporaryDirectory]] == 1} {
|
||||
error $msg
|
||||
@@ -1040,7 +1040,7 @@ test tcltest-15.1 {basic directory walking} {
|
||||
test tcltest-15.2 {-asidefromdir} {
|
||||
-constraints {unixOrWin}
|
||||
-body {
|
||||
if {[slave msg \
|
||||
if {[child msg \
|
||||
[file join $dtd all.tcl] \
|
||||
-asidefromdir dirtestdir2.3 \
|
||||
-tmpdir [temporaryDirectory]] == 1} {
|
||||
@@ -1058,7 +1058,7 @@ Error: No test files remain after applying your match and skip patterns!$}
|
||||
test tcltest-15.3 {-relateddir, non-existent dir} {
|
||||
-constraints {unixOrWin}
|
||||
-body {
|
||||
if {[slave msg \
|
||||
if {[child msg \
|
||||
[file join $dtd all.tcl] \
|
||||
-relateddir [file join [temporaryDirectory] dirtestdir0] \
|
||||
-tmpdir [temporaryDirectory]] == 1} {
|
||||
@@ -1073,7 +1073,7 @@ test tcltest-15.3 {-relateddir, non-existent dir} {
|
||||
test tcltest-15.4 {-relateddir, subdir} {
|
||||
-constraints {unixOrWin}
|
||||
-body {
|
||||
if {[slave msg \
|
||||
if {[child msg \
|
||||
[file join $dtd all.tcl] \
|
||||
-relateddir dirtestdir2.1 -tmpdir [temporaryDirectory]] == 1} {
|
||||
error $msg
|
||||
@@ -1086,7 +1086,7 @@ test tcltest-15.4 {-relateddir, subdir} {
|
||||
test tcltest-15.5 {-relateddir, -asidefromdir} {
|
||||
-constraints {unixOrWin}
|
||||
-body {
|
||||
if {[slave msg \
|
||||
if {[child msg \
|
||||
[file join $dtd all.tcl] \
|
||||
-relateddir "dirtestdir2.1 dirtestdir2.2" \
|
||||
-asidefromdir dirtestdir2.2 \
|
||||
@@ -1147,25 +1147,25 @@ test tcltest-19.1 {TCLTEST_OPTIONS default} -setup {
|
||||
# set this to { } instead of just {} to get around quirk in
|
||||
# Windows env handling that removes empty elements from env array.
|
||||
set ::env(TCLTEST_OPTIONS) { }
|
||||
interp create slave1
|
||||
slave1 eval [list set argv {-debug 2}]
|
||||
slave1 alias puts puts
|
||||
interp create slave2
|
||||
slave2 alias puts puts
|
||||
interp create child1
|
||||
child1 eval [list set argv {-debug 2}]
|
||||
child1 alias puts puts
|
||||
interp create child2
|
||||
child2 alias puts puts
|
||||
} -cleanup {
|
||||
interp delete slave2
|
||||
interp delete slave1
|
||||
interp delete child2
|
||||
interp delete child1
|
||||
if {$oldoptions eq "none"} {
|
||||
unset ::env(TCLTEST_OPTIONS)
|
||||
} else {
|
||||
set ::env(TCLTEST_OPTIONS) $oldoptions
|
||||
}
|
||||
} -body {
|
||||
slave1 eval [package ifneeded tcltest [package provide tcltest]]
|
||||
slave1 eval tcltest::debug
|
||||
child1 eval [package ifneeded tcltest [package provide tcltest]]
|
||||
child1 eval tcltest::debug
|
||||
set ::env(TCLTEST_OPTIONS) "-debug 3"
|
||||
slave2 eval [package ifneeded tcltest [package provide tcltest]]
|
||||
slave2 eval tcltest::debug
|
||||
child2 eval [package ifneeded tcltest [package provide tcltest]]
|
||||
child2 eval tcltest::debug
|
||||
} -result {^3$} -match regexp -output\
|
||||
{tcltest::debug\s+= 2.*tcltest::debug\s+= 3}
|
||||
|
||||
@@ -1174,7 +1174,7 @@ test tcltest-19.1 {TCLTEST_OPTIONS default} -setup {
|
||||
cd [temporaryDirectory]
|
||||
# PrintError
|
||||
test tcltest-20.1 {PrintError} {unixOrWin} {
|
||||
set result [slave msg $printerror]
|
||||
set result [child msg $printerror]
|
||||
list $result [regexp "Error: a really short string" $msg] \
|
||||
[regexp " \"quotes\"" $msg] [regexp " \"Path" $msg] \
|
||||
[regexp " \"Really" $msg] [regexp Problem $msg]
|
||||
@@ -1407,7 +1407,7 @@ makeFile {
|
||||
} test.test $atd
|
||||
|
||||
# Must use a child process because stdout/stderr parsing can't be
|
||||
# duplicated in slave interp.
|
||||
# duplicated in child interp.
|
||||
test tcltest-22.1 {runAllTests} {
|
||||
-constraints {unixOrWin}
|
||||
-body {
|
||||
@@ -1806,7 +1806,7 @@ test tcltest-26.1 {Bug/RFE 1017151} -setup {
|
||||
tcltest::cleanupTests
|
||||
} test.tcl
|
||||
} -body {
|
||||
slave msg [file join [temporaryDirectory] test.tcl]
|
||||
child msg [file join [temporaryDirectory] test.tcl]
|
||||
return $msg
|
||||
} -cleanup {
|
||||
removeFile test.tcl
|
||||
@@ -1826,7 +1826,7 @@ test tcltest-26.2 {Bug/RFE 1017151} -setup {
|
||||
tcltest::cleanupTests
|
||||
} test.tcl
|
||||
} -body {
|
||||
slave msg [file join [temporaryDirectory] test.tcl]
|
||||
child msg [file join [temporaryDirectory] test.tcl]
|
||||
return $msg
|
||||
} -cleanup {
|
||||
removeFile test.tcl
|
||||
|
||||
+2
-2
@@ -802,7 +802,7 @@ test thread-7.21 {cancel: subst -unwind} -constraints {thread drainEventQueue} -
|
||||
} -cleanup {
|
||||
unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
|
||||
} -result {{} 1 1 {eval unwound}}
|
||||
test thread-7.22 {cancel: slave interp} -constraints {thread drainEventQueue} -setup {
|
||||
test thread-7.22 {cancel: child interp} -constraints {thread drainEventQueue} -setup {
|
||||
unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
|
||||
} -body {
|
||||
set serverthread [thread::create -joinable \
|
||||
@@ -832,7 +832,7 @@ test thread-7.22 {cancel: slave interp} -constraints {thread drainEventQueue} -s
|
||||
} -cleanup {
|
||||
unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
|
||||
} -result {{} 1 1 {eval canceled}}
|
||||
test thread-7.23 {cancel: slave interp -unwind} -constraints {thread drainEventQueue} -setup {
|
||||
test thread-7.23 {cancel: child interp -unwind} -constraints {thread drainEventQueue} -setup {
|
||||
unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
|
||||
} -body {
|
||||
set serverthread [thread::create -joinable \
|
||||
|
||||
+6
-6
@@ -568,15 +568,15 @@ test timer-9.1 {AfterCleanupProc procedure} -setup {
|
||||
} -result {before after2 after4}
|
||||
|
||||
test timer-10.1 {Bug 1016167: [after] overwrites imports} -setup {
|
||||
interp create slave
|
||||
slave eval namespace export after
|
||||
slave eval namespace eval foo namespace import ::after
|
||||
interp create child
|
||||
child eval namespace export after
|
||||
child eval namespace eval foo namespace import ::after
|
||||
} -body {
|
||||
slave eval foo::after 1
|
||||
slave eval namespace origin foo::after
|
||||
child eval foo::after 1
|
||||
child eval namespace origin foo::after
|
||||
} -cleanup {
|
||||
# Bug will cause crash here; would cause failure otherwise
|
||||
interp delete slave
|
||||
interp delete child
|
||||
} -result ::after
|
||||
|
||||
test timer-11.1 {Bug 1350291: [after] overflowing 32-bit field} -body {
|
||||
|
||||
+5
-5
@@ -2197,11 +2197,11 @@ foo {if {[catch {bar}]} {
|
||||
}} 2 error leavestep
|
||||
foo foo 0 error leave}}
|
||||
|
||||
test trace-28.4 {exec traces in slave with 'return -code error'} {
|
||||
interp create slave
|
||||
interp alias slave traceExecute {} traceExecute
|
||||
test trace-28.4 {exec traces in child with 'return -code error'} {
|
||||
interp create child
|
||||
interp alias child traceExecute {} traceExecute
|
||||
set info {}
|
||||
set res [interp eval slave {
|
||||
set res [interp eval child {
|
||||
set info {}
|
||||
set res {}
|
||||
|
||||
@@ -2229,7 +2229,7 @@ test trace-28.4 {exec traces in slave with 'return -code error'} {
|
||||
|
||||
list $res
|
||||
}]
|
||||
interp delete slave
|
||||
interp delete child
|
||||
lappend res [join $info \n]
|
||||
} {{error error} {foo foo enter
|
||||
foo {if {[catch {bar}]} {
|
||||
|
||||
+3
-3
@@ -1046,15 +1046,15 @@ test var-22.1 {leak in localVarName intrep: Bug 80304238ac} -setup {
|
||||
lindex [split [memory info] \n] 3 3
|
||||
}
|
||||
proc doit {} {
|
||||
interp create slave
|
||||
slave eval {
|
||||
interp create child
|
||||
child eval {
|
||||
proc doit script {
|
||||
eval $script
|
||||
set foo bar
|
||||
}
|
||||
doit {foreach foo baz {}}
|
||||
}
|
||||
interp delete slave
|
||||
interp delete child
|
||||
}
|
||||
} -constraints memory -body {
|
||||
set end [getbytes]
|
||||
|
||||
+89
-89
@@ -279,19 +279,19 @@ test winDde-6.6 {DDE remote servername collision force} -constraints {dde stdio}
|
||||
|
||||
# -------------------------------------------------------------------------
|
||||
|
||||
test winDde-7.1 {Load DDE in slave interpreter} -constraints dde -setup {
|
||||
interp create slave
|
||||
test winDde-7.1 {Load DDE in child interpreter} -constraints dde -setup {
|
||||
interp create child
|
||||
} -body {
|
||||
slave eval [list load $::ddelib Dde]
|
||||
slave eval [list dde servername -- dde-interp-7.1]
|
||||
child eval [list load $::ddelib Dde]
|
||||
child eval [list dde servername -- dde-interp-7.1]
|
||||
} -cleanup {
|
||||
interp delete slave
|
||||
interp delete child
|
||||
} -result {dde-interp-7.1}
|
||||
test winDde-7.2 {DDE slave cleanup} -constraints dde -setup {
|
||||
interp create slave
|
||||
slave eval [list load $::ddelib Dde]
|
||||
slave eval [list dde servername -- dde-interp-7.5]
|
||||
interp delete slave
|
||||
test winDde-7.2 {DDE child cleanup} -constraints dde -setup {
|
||||
interp create child
|
||||
child eval [list load $::ddelib Dde]
|
||||
child eval [list dde servername -- dde-interp-7.5]
|
||||
interp delete child
|
||||
} -body {
|
||||
dde services TclEval {}
|
||||
set s [dde services TclEval {}]
|
||||
@@ -300,128 +300,128 @@ test winDde-7.2 {DDE slave cleanup} -constraints dde -setup {
|
||||
set s
|
||||
}
|
||||
} -result {}
|
||||
test winDde-7.3 {DDE present in slave interp} -constraints dde -setup {
|
||||
interp create slave
|
||||
slave eval [list load $::ddelib Dde]
|
||||
slave eval [list dde servername -- dde-interp-7.3]
|
||||
test winDde-7.3 {DDE present in child interp} -constraints dde -setup {
|
||||
interp create child
|
||||
child eval [list load $::ddelib Dde]
|
||||
child eval [list dde servername -- dde-interp-7.3]
|
||||
} -body {
|
||||
dde services TclEval dde-interp-7.3
|
||||
} -cleanup {
|
||||
interp delete slave
|
||||
interp delete child
|
||||
} -result {{TclEval dde-interp-7.3}}
|
||||
test winDde-7.4 {interp name collision with -force} -constraints dde -setup {
|
||||
interp create slave
|
||||
slave eval [list load $::ddelib Dde]
|
||||
slave eval [list dde servername -- dde-interp-7.4]
|
||||
interp create child
|
||||
child eval [list load $::ddelib Dde]
|
||||
child eval [list dde servername -- dde-interp-7.4]
|
||||
} -body {
|
||||
dde servername -force -- dde-interp-7.4
|
||||
} -cleanup {
|
||||
interp delete slave
|
||||
interp delete child
|
||||
} -result {dde-interp-7.4}
|
||||
test winDde-7.5 {interp name collision without -force} -constraints dde -setup {
|
||||
interp create slave
|
||||
slave eval [list load $::ddelib Dde]
|
||||
slave eval [list dde servername -- dde-interp-7.5]
|
||||
interp create child
|
||||
child eval [list load $::ddelib Dde]
|
||||
child eval [list dde servername -- dde-interp-7.5]
|
||||
} -body {
|
||||
dde servername -- dde-interp-7.5
|
||||
} -cleanup {
|
||||
interp delete slave
|
||||
interp delete child
|
||||
} -result "dde-interp-7.5 #2"
|
||||
|
||||
# -------------------------------------------------------------------------
|
||||
|
||||
test winDde-8.1 {Safe DDE load} -constraints dde -setup {
|
||||
interp create -safe slave
|
||||
slave invokehidden load $::ddelib Dde
|
||||
interp create -safe child
|
||||
child invokehidden load $::ddelib Dde
|
||||
} -body {
|
||||
slave eval dde servername slave
|
||||
child eval dde servername child
|
||||
} -cleanup {
|
||||
interp delete slave
|
||||
interp delete child
|
||||
} -returnCodes error -result {invalid command name "dde"}
|
||||
test winDde-8.2 {Safe DDE set servername} -constraints dde -setup {
|
||||
interp create -safe slave
|
||||
slave invokehidden load $::ddelib Dde
|
||||
interp create -safe child
|
||||
child invokehidden load $::ddelib Dde
|
||||
} -body {
|
||||
slave invokehidden dde servername slave
|
||||
} -cleanup {interp delete slave} -result {slave}
|
||||
child invokehidden dde servername child
|
||||
} -cleanup {interp delete child} -result {child}
|
||||
test winDde-8.3 {Safe DDE check handler required for eval} -constraints dde -setup {
|
||||
interp create -safe slave
|
||||
slave invokehidden load $::ddelib Dde
|
||||
slave invokehidden dde servername slave
|
||||
interp create -safe child
|
||||
child invokehidden load $::ddelib Dde
|
||||
child invokehidden dde servername child
|
||||
} -body {
|
||||
catch {dde eval slave set a 1} msg
|
||||
} -cleanup {interp delete slave} -result {1}
|
||||
catch {dde eval child set a 1} msg
|
||||
} -cleanup {interp delete child} -result {1}
|
||||
test winDde-8.4 {Safe DDE check that execute is denied} -constraints dde -setup {
|
||||
interp create -safe slave
|
||||
slave invokehidden load $::ddelib Dde
|
||||
slave invokehidden dde servername slave
|
||||
interp create -safe child
|
||||
child invokehidden load $::ddelib Dde
|
||||
child invokehidden dde servername child
|
||||
} -body {
|
||||
slave eval set a 1
|
||||
dde execute TclEval slave {set a 2}
|
||||
slave eval set a
|
||||
} -cleanup {interp delete slave} -result 1
|
||||
child eval set a 1
|
||||
dde execute TclEval child {set a 2}
|
||||
child eval set a
|
||||
} -cleanup {interp delete child} -result 1
|
||||
test winDde-8.5 {Safe DDE check that request is denied} -constraints dde -setup {
|
||||
interp create -safe slave
|
||||
slave invokehidden load $::ddelib Dde
|
||||
slave invokehidden dde servername slave
|
||||
interp create -safe child
|
||||
child invokehidden load $::ddelib Dde
|
||||
child invokehidden dde servername child
|
||||
} -body {
|
||||
slave eval set a 1
|
||||
dde request TclEval slave a
|
||||
child eval set a 1
|
||||
dde request TclEval child a
|
||||
} -cleanup {
|
||||
interp delete slave
|
||||
interp delete child
|
||||
} -returnCodes error -result {remote server cannot handle this command}
|
||||
test winDde-8.6 {Safe DDE assign handler procedure} -constraints dde -setup {
|
||||
interp create -safe slave
|
||||
slave invokehidden load $::ddelib Dde
|
||||
slave eval {proc DDEACCEPT {cmd} {set ::DDECMD $cmd}}
|
||||
interp create -safe child
|
||||
child invokehidden load $::ddelib Dde
|
||||
child eval {proc DDEACCEPT {cmd} {set ::DDECMD $cmd}}
|
||||
} -body {
|
||||
slave invokehidden dde servername -handler DDEACCEPT slave
|
||||
} -cleanup {interp delete slave} -result slave
|
||||
child invokehidden dde servername -handler DDEACCEPT child
|
||||
} -cleanup {interp delete child} -result child
|
||||
test winDde-8.7 {Safe DDE check simple command} -constraints dde -setup {
|
||||
interp create -safe slave
|
||||
slave invokehidden load $::ddelib Dde
|
||||
slave eval {proc DDEACCEPT {cmd} {set ::DDECMD $cmd}}
|
||||
slave invokehidden dde servername -handler DDEACCEPT slave
|
||||
interp create -safe child
|
||||
child invokehidden load $::ddelib Dde
|
||||
child eval {proc DDEACCEPT {cmd} {set ::DDECMD $cmd}}
|
||||
child invokehidden dde servername -handler DDEACCEPT child
|
||||
} -body {
|
||||
dde eval slave set x 1
|
||||
} -cleanup {interp delete slave} -result {set x 1}
|
||||
dde eval child set x 1
|
||||
} -cleanup {interp delete child} -result {set x 1}
|
||||
test winDde-8.8 {Safe DDE check non-list command} -constraints dde -setup {
|
||||
interp create -safe slave
|
||||
slave invokehidden load $::ddelib Dde
|
||||
slave eval {proc DDEACCEPT {cmd} {set ::DDECMD $cmd}}
|
||||
slave invokehidden dde servername -handler DDEACCEPT slave
|
||||
interp create -safe child
|
||||
child invokehidden load $::ddelib Dde
|
||||
child eval {proc DDEACCEPT {cmd} {set ::DDECMD $cmd}}
|
||||
child invokehidden dde servername -handler DDEACCEPT child
|
||||
} -body {
|
||||
set s "c:\\Program Files\\Microsoft Visual Studio\\"
|
||||
dde eval slave $s
|
||||
string equal [slave eval set DDECMD] $s
|
||||
} -cleanup {interp delete slave} -result 1
|
||||
dde eval child $s
|
||||
string equal [child eval set DDECMD] $s
|
||||
} -cleanup {interp delete child} -result 1
|
||||
test winDde-8.9 {Safe DDE check command evaluation} -constraints dde -setup {
|
||||
interp create -safe slave
|
||||
slave invokehidden load $::ddelib Dde
|
||||
slave eval {proc DDEACCEPT {cmd} {set ::DDECMD [uplevel \#0 $cmd]}}
|
||||
slave invokehidden dde servername -handler DDEACCEPT slave
|
||||
interp create -safe child
|
||||
child invokehidden load $::ddelib Dde
|
||||
child eval {proc DDEACCEPT {cmd} {set ::DDECMD [uplevel \#0 $cmd]}}
|
||||
child invokehidden dde servername -handler DDEACCEPT child
|
||||
} -body {
|
||||
dde eval slave set \xe1 1
|
||||
slave eval set \xe1
|
||||
} -cleanup {interp delete slave} -result 1
|
||||
dde eval child set \xe1 1
|
||||
child eval set \xe1
|
||||
} -cleanup {interp delete child} -result 1
|
||||
test winDde-8.10 {Safe DDE check command evaluation (2)} -constraints dde -setup {
|
||||
interp create -safe slave
|
||||
slave invokehidden load $::ddelib Dde
|
||||
slave eval {proc DDEACCEPT {cmd} {set ::DDECMD [uplevel \#0 $cmd]}}
|
||||
slave invokehidden dde servername -handler DDEACCEPT slave
|
||||
interp create -safe child
|
||||
child invokehidden load $::ddelib Dde
|
||||
child eval {proc DDEACCEPT {cmd} {set ::DDECMD [uplevel \#0 $cmd]}}
|
||||
child invokehidden dde servername -handler DDEACCEPT child
|
||||
} -body {
|
||||
dde eval slave [list set x 1]
|
||||
slave eval set x
|
||||
} -cleanup {interp delete slave} -result 1
|
||||
dde eval child [list set x 1]
|
||||
child eval set x
|
||||
} -cleanup {interp delete child} -result 1
|
||||
test winDde-8.11 {Safe DDE check command evaluation (3)} -constraints dde -setup {
|
||||
interp create -safe slave
|
||||
slave invokehidden load $::ddelib Dde
|
||||
slave eval {proc DDEACCEPT {cmd} {set ::DDECMD [uplevel \#0 $cmd]}}
|
||||
slave invokehidden dde servername -handler DDEACCEPT slave
|
||||
interp create -safe child
|
||||
child invokehidden load $::ddelib Dde
|
||||
child eval {proc DDEACCEPT {cmd} {set ::DDECMD [uplevel \#0 $cmd]}}
|
||||
child invokehidden dde servername -handler DDEACCEPT child
|
||||
} -body {
|
||||
dde eval slave [list [list set x 1]]
|
||||
slave eval set x
|
||||
} -cleanup {interp delete slave} -returnCodes error -result {invalid command name "set x 1"}
|
||||
dde eval child [list [list set x 1]]
|
||||
child eval set x
|
||||
} -cleanup {interp delete child} -returnCodes error -result {invalid command name "set x 1"}
|
||||
|
||||
# -------------------------------------------------------------------------
|
||||
|
||||
@@ -481,7 +481,7 @@ test winDde-9.4 {External safe DDE check null data passing} -constraints {dde st
|
||||
# -------------------------------------------------------------------------
|
||||
|
||||
#cleanup
|
||||
#catch {interp delete $slave}; # ensure we clean up the slave.
|
||||
#catch {interp delete $child}; # ensure we clean up the child.
|
||||
file delete -force $::scriptName
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
|
||||
+1
-1
@@ -2027,7 +2027,7 @@ rpm: all
|
||||
rm -rf RPMS THIS.TCL.SPEC
|
||||
|
||||
#
|
||||
# Target to create a proper Tcl distribution from information in the master
|
||||
# Target to create a proper Tcl distribution from information in the main
|
||||
# source directory. DISTDIR must be defined to indicate where to put the
|
||||
# distribution. DISTDIR must be an absolute path name.
|
||||
#
|
||||
|
||||
+3
-3
@@ -514,7 +514,7 @@ CFG_ENCODING = \"cp1252\"
|
||||
# information about supported compiler options etc.
|
||||
#
|
||||
# Tcl itself will always use the nmakehlp.c program which is
|
||||
# in its own source. This is the "master" copy and kept updated.
|
||||
# in its own source. This is the "main" copy and kept updated.
|
||||
#
|
||||
# Extensions built against an installed Tcl will use the installed
|
||||
# copy of Tcl's nmakehlp.c if there is one and their own version
|
||||
@@ -1669,7 +1669,7 @@ default-shell: default-setup $(PROJECT)
|
||||
!ifdef RCFILE
|
||||
|
||||
# Note: don't use $** in below rule because there may be other dependencies
|
||||
# and only the "master" rc must be passed to the resource compiler
|
||||
# and only the "main" rc must be passed to the resource compiler
|
||||
$(TMP_DIR)\$(PROJECT).res: $(RCDIR)\$(PROJECT).rc
|
||||
$(RESCMD) $(RCDIR)\$(PROJECT).rc
|
||||
|
||||
@@ -1723,7 +1723,7 @@ DISABLE_IMPLICIT_RULES = 0
|
||||
|
||||
!if !$(DISABLE_IMPLICIT_RULES)
|
||||
# Implicit rule definitions - only for building library objects. For stubs and
|
||||
# main application, the master makefile should define explicit rules.
|
||||
# main application, the main makefile should define explicit rules.
|
||||
|
||||
{$(ROOT)}.c{$(TMP_DIR)}.obj::
|
||||
$(CCPKGCMD) @<<
|
||||
|
||||
Reference in New Issue
Block a user