Tcl Source Code

Changes On Branch tip-284
Login
Bounty program for improvements to Tcl and certain Tcl packages.

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

Changes In Branch tip-284 Excluding Merge-Ins

This is equivalent to a diff from 7bcb41aa5e to 210c48ba31

2019-05-28
21:42
Merge 8.6 check-in: f70e8b4830 user: jan.nijtmans tags: core-8-branch
2019-05-26
21:03
tests for [invoke] and [namespace invoke] Leaf check-in: 210c48ba31 user: dkf tags: tip-284
15:36
Added docs check-in: 42e7c8ef38 user: dkf tags: tip-284
12:11
Import of old TIP 284 patch, and update for current Tcl check-in: 1832e6f878 user: dkf tags: tip-284
07:19
merge 8.7 check-in: 494534d018 user: dkf tags: tip-480
2019-05-25
08:17
Merge 8.7 check-in: dd82009b2c user: dkf tags: trunk
08:06
TIP 383: [coroinject] and [coroprobe] check-in: 7bcb41aa5e user: dkf tags: core-8-branch
08:01
Add to error info when passing an error out of [coroprobe] Closed-Leaf check-in: de44589e23 user: dkf tags: tip-383
07:46
Implement TIP 431: [file tempdir] check-in: 974c5d161d user: dkf tags: core-8-branch

Added doc/invoke.n.








































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\" Copyright (c) 2019 Donal K Fellows.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.TH invoke n 8.7 Tcl "Tcl Built-In Commands"
.so man.macros
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
invoke \- Execute a command in a different stack frame
.SH SYNOPSIS
\fBinvoke \fIlevel command \fR?\fIarg ...\fR?
.BE
.SH DESCRIPTION
.PP
The \fBinvoke\fR command concatenates \fIcommand\fR with all of the \fIarg\fR
arguments as if they had been passed to \fBlist\fR; it then evaluates the
result in the variable context indicated by \fIlevel\fR.  \fBInvoke\fR returns
the result of that evaluation.
.PP
If \fIlevel\fR is an integer then it gives a distance (up the procedure
calling stack) to move before executing the command.  If \fIlevel\fR consists
of \fB#\fR followed by a integer then the level gives an absolute level.
.PP
For example, suppose that procedure \fBa\fR was invoked from top-level, and
that it called \fBb\fR, and that \fBb\fR called \fBc\fR.  Suppose that \fBc\fR
invokes the \fBinvoke\fR command.  If \fIlevel\fR is \fB1\fR or \fB#2\fR, then
the command will be executed in the variable context of \fBb\fR.  If
\fIlevel\fR is \fB2\fR or \fB#1\fR then the command will be executed in the
variable context of \fBa\fR.  If \fIlevel\fR is \fB3\fR or \fB#0\fR then the
command will be executed at top-level (only global variables will be visible).
.PP
The \fBinvoke\fR command causes the invoking procedure to disappear from the
procedure calling stack while the command is being executed.  In the above
example, suppose \fBc\fR invokes the command
.PP
.CS
\fBinvoke\fR 1 set x "some arbitrary string"
.CE
.PP
where \fBd\fR is another Tcl procedure.  The \fBset\fR command will modify the
variable \fBx\fR in \fBb\fR's context, at level 3, as if called from \fBb\fR:
the procedure \fBc\fR does not appear to be on the call stack when the
\fBset\fR is executing.  The \fBinfo level\fR command may be used to obtain
the level of the current procedure.
.PP
\fBInvoke\fR makes it possible to implement new control constructs as Tcl
procedures, and is useful in situations where the caller of \fBinvoke\fR is in
control of the arguments (unlike with \fBuplevel\fR which is more suitable for
calling a script provided by the caller of the procedure).
.PP
The \fBnamespace eval\fR and \fBapply\fR commands and TclOO methods offer
other ways (besides procedure calls) that the Tcl naming context can change.
They add a call frame to the stack to represent the namespace context.  This
means each \fBnamespace eval\fR command counts as another call level for
\fBinvoke\fR and \fBupvar\fR commands.  For example, \fBinfo level 1\fR will
return a list describing a command that is either the outermost procedure call
or the outermost \fBnamespace eval\fR command.  Also, \fBinvoke #0\fR
evaluates a command at top-level in the outermost namespace (the global
namespace).
.SH EXAMPLE
As stated above, the \fBinvoke\fR command is useful for creating new control
constructs.  This example shows how (ignoring \fBupvar\fRed variables and
arrays) it can be used to create a \fIlambda\fR command that creates a lambda
term (using \fBapply\fR) that can be in the same namespace context as the
caller of \fBlambda\fR with a copy (effectively read-only) of the local
variables in the stack frame it was called from, for effectively
lexically-scoped variables:
.PP
.CS
proc \fIlambda\fR {args body} {
    set locals [\fBinvoke\fR 1 info locals]
    set arguments [list {*}$locals {*}$args]
    set ns [\fBinvoke\fR 1 namespace current]
    set values [lmap var $locals {\fBinvoke\fR 1 set $var}]
    return [list apply [list $arguments $body $ns] {*}$values]
}

\fI# Demonstrating it in use\fR
namespace eval foo {
    variable b {}

    proc bar {x y} {
        set z [expr {$x + $y}]

        return [\fIlambda\fR a {
            variable b
            lappend b $a
            return $x,$y,$z,$a,[join $b "|"]
        }]
    }
}

set with23 [foo::bar 2 3]
puts [{*}$with23 "demo"]
\fI# ==> 2,3,5,demo,demo\fR
puts [{*}$with23 "again"]
\fI# ==> 2,3,5,again,demo|again\fR

set with45 [foo::bar 4 5]
puts [{*}$with45 "more"]
\fI# ==> 4,5,9,more,demo|again|more\fR
puts [{*}$with23 "again"]
\fI# ==> 2,3,5,again,demo|again|more|again\fR
.CE
.SH "SEE ALSO"
apply(n), namespace(n), uplevel(n), upvar(n)
.SH KEYWORDS
context, level, namespace, stack frame, variable
.\" Local Variables:
.\" mode: nroff
.\" End:

Changes to doc/namespace.n.

201
202
203
204
205
206
207









208
209
210
211
212
213
214
that is, only requested commands that are currently defined
in the exporting namespace are imported.
In other words, you can import only the commands that are in a namespace
at the time when the \fBnamespace import\fR command is executed.
If another command is defined and exported in this namespace later on,
it will not be imported.
.RE









.TP
\fBnamespace inscope\fR \fInamespace\fR \fIscript\fR ?\fIarg ...\fR?
.
Executes a script in the context of the specified \fInamespace\fR.
This command is not expected to be used directly by programmers;
calls to it are generated implicitly when applications
use \fBnamespace code\fR commands to create callback scripts






>
>
>
>
>
>
>
>
>







201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
that is, only requested commands that are currently defined
in the exporting namespace are imported.
In other words, you can import only the commands that are in a namespace
at the time when the \fBnamespace import\fR command is executed.
If another command is defined and exported in this namespace later on,
it will not be imported.
.RE
.TP
\fBnamespace invoke\fR \fInamespace cmd\fR ?\fIarg ...\fR?
.VS "TIP 284"
Invokes the command called \fIcmd\fR, as resolved from namespace
\fInamespace\fR, with the supplied arguments; the command is invoked
in the scope of the caller of \fBnamespace invoke\fR, so there are no
intervening stack frames. If \fInamespace\fR does not exist, the
command returns an error.
.VE "TIP 284"
.TP
\fBnamespace inscope\fR \fInamespace\fR \fIscript\fR ?\fIarg ...\fR?
.
Executes a script in the context of the specified \fInamespace\fR.
This command is not expected to be used directly by programmers;
calls to it are generated implicitly when applications
use \fBnamespace code\fR commands to create callback scripts

Changes to doc/uplevel.n.

91
92
93
94
95
96
97
98
99
100
101
102
103
        if {![\fBuplevel\fR 1 $conditionCmd]} {
            break
        }
    }
}
.CE
.SH "SEE ALSO"
apply(n), namespace(n), upvar(n)
.SH KEYWORDS
context, level, namespace, stack frame, variable
.\" Local Variables:
.\" mode: nroff
.\" End:






|





91
92
93
94
95
96
97
98
99
100
101
102
103
        if {![\fBuplevel\fR 1 $conditionCmd]} {
            break
        }
    }
}
.CE
.SH "SEE ALSO"
apply(n), invoke(n), namespace(n), upvar(n)
.SH KEYWORDS
context, level, namespace, stack frame, variable
.\" Local Variables:
.\" mode: nroff
.\" End:

Changes to generic/tclBasic.c.

255
256
257
258
259
260
261

262
263
264
265
266
267
268
    {"expr",		Tcl_ExprObjCmd,		TclCompileExprCmd,	TclNRExprObjCmd,	CMD_IS_SAFE},
    {"for",		Tcl_ForObjCmd,		TclCompileForCmd,	TclNRForObjCmd,	CMD_IS_SAFE},
    {"foreach",		Tcl_ForeachObjCmd,	TclCompileForeachCmd,	TclNRForeachCmd,	CMD_IS_SAFE},
    {"format",		Tcl_FormatObjCmd,	TclCompileFormatCmd,	NULL,	CMD_IS_SAFE},
    {"global",		Tcl_GlobalObjCmd,	TclCompileGlobalCmd,	NULL,	CMD_IS_SAFE},
    {"if",		Tcl_IfObjCmd,		TclCompileIfCmd,	TclNRIfObjCmd,	CMD_IS_SAFE},
    {"incr",		Tcl_IncrObjCmd,		TclCompileIncrCmd,	NULL,	CMD_IS_SAFE},

    {"join",		Tcl_JoinObjCmd,		NULL,			NULL,	CMD_IS_SAFE},
    {"lappend",		Tcl_LappendObjCmd,	TclCompileLappendCmd,	NULL,	CMD_IS_SAFE},
    {"lassign",		Tcl_LassignObjCmd,	TclCompileLassignCmd,	NULL,	CMD_IS_SAFE},
    {"lindex",		Tcl_LindexObjCmd,	TclCompileLindexCmd,	NULL,	CMD_IS_SAFE},
    {"linsert",		Tcl_LinsertObjCmd,	TclCompileLinsertCmd,	NULL,	CMD_IS_SAFE},
    {"list",		Tcl_ListObjCmd,		TclCompileListCmd,	NULL,	CMD_IS_SAFE|CMD_COMPILES_EXPANDED},
    {"llength",		Tcl_LlengthObjCmd,	TclCompileLlengthCmd,	NULL,	CMD_IS_SAFE},






>







255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
    {"expr",		Tcl_ExprObjCmd,		TclCompileExprCmd,	TclNRExprObjCmd,	CMD_IS_SAFE},
    {"for",		Tcl_ForObjCmd,		TclCompileForCmd,	TclNRForObjCmd,	CMD_IS_SAFE},
    {"foreach",		Tcl_ForeachObjCmd,	TclCompileForeachCmd,	TclNRForeachCmd,	CMD_IS_SAFE},
    {"format",		Tcl_FormatObjCmd,	TclCompileFormatCmd,	NULL,	CMD_IS_SAFE},
    {"global",		Tcl_GlobalObjCmd,	TclCompileGlobalCmd,	NULL,	CMD_IS_SAFE},
    {"if",		Tcl_IfObjCmd,		TclCompileIfCmd,	TclNRIfObjCmd,	CMD_IS_SAFE},
    {"incr",		Tcl_IncrObjCmd,		TclCompileIncrCmd,	NULL,	CMD_IS_SAFE},
    {"invoke",		Tcl_InvokeObjCmd,	NULL,			TclNRInvokeObjCmd,	CMD_IS_SAFE},
    {"join",		Tcl_JoinObjCmd,		NULL,			NULL,	CMD_IS_SAFE},
    {"lappend",		Tcl_LappendObjCmd,	TclCompileLappendCmd,	NULL,	CMD_IS_SAFE},
    {"lassign",		Tcl_LassignObjCmd,	TclCompileLassignCmd,	NULL,	CMD_IS_SAFE},
    {"lindex",		Tcl_LindexObjCmd,	TclCompileLindexCmd,	NULL,	CMD_IS_SAFE},
    {"linsert",		Tcl_LinsertObjCmd,	TclCompileLinsertCmd,	NULL,	CMD_IS_SAFE},
    {"list",		Tcl_ListObjCmd,		TclCompileListCmd,	NULL,	CMD_IS_SAFE|CMD_COMPILES_EXPANDED},
    {"llength",		Tcl_LlengthObjCmd,	TclCompileLlengthCmd,	NULL,	CMD_IS_SAFE},

Changes to generic/tclInt.h.

2804
2805
2806
2807
2808
2809
2810

2811
2812
2813
2814
2815
2816
2817
....
3435
3436
3437
3438
3439
3440
3441



3442
3443
3444
3445
3446
3447
3448
MODULE_SCOPE Tcl_ObjCmdProc TclNRApplyObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNREvalObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRCatchObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRExprObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRForObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRForeachCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRIfObjCmd;

MODULE_SCOPE Tcl_ObjCmdProc TclNRLmapCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRPackageObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRSourceObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRSubstObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRSwitchObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRTryObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRUplevelObjCmd;
................................................................................
			    Tcl_Obj *const objv[]);
MODULE_SCOPE int	Tcl_IncrObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);
MODULE_SCOPE Tcl_Command TclInitInfoCmd(Tcl_Interp *interp);
MODULE_SCOPE int	Tcl_InterpObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int argc,



			    Tcl_Obj *const objv[]);
MODULE_SCOPE int	Tcl_JoinObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);
MODULE_SCOPE int	Tcl_LappendObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);






>







 







>
>
>







2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815
2816
2817
2818
....
3436
3437
3438
3439
3440
3441
3442
3443
3444
3445
3446
3447
3448
3449
3450
3451
3452
MODULE_SCOPE Tcl_ObjCmdProc TclNRApplyObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNREvalObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRCatchObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRExprObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRForObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRForeachCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRIfObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRInvokeObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRLmapCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRPackageObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRSourceObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRSubstObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRSwitchObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRTryObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRUplevelObjCmd;
................................................................................
			    Tcl_Obj *const objv[]);
MODULE_SCOPE int	Tcl_IncrObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);
MODULE_SCOPE Tcl_Command TclInitInfoCmd(Tcl_Interp *interp);
MODULE_SCOPE int	Tcl_InterpObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int argc,
			    Tcl_Obj *const objv[]);
MODULE_SCOPE int	Tcl_InvokeObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);
MODULE_SCOPE int	Tcl_JoinObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);
MODULE_SCOPE int	Tcl_LappendObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);

Changes to generic/tclNamesp.c.

109
110
111
112
113
114
115




116
117
118
119
120
121
122
...
181
182
183
184
185
186
187

188
189
190
191
192
193
194
....
3752
3753
3754
3755
3756
3757
3758














































































































3759
3760
3761
3762
3763
3764
3765
static int		NamespaceExportCmd(ClientData dummy,Tcl_Interp *interp,
			    int objc, Tcl_Obj *const objv[]);
static int		NamespaceForgetCmd(ClientData dummy,Tcl_Interp *interp,
			    int objc, Tcl_Obj *const objv[]);
static void		NamespaceFree(Namespace *nsPtr);
static int		NamespaceImportCmd(ClientData dummy,Tcl_Interp *interp,
			    int objc, Tcl_Obj *const objv[]);




static int		NamespaceInscopeCmd(ClientData dummy,
			    Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
static int		NRNamespaceInscopeCmd(ClientData dummy,
			    Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
static int		NamespaceOriginCmd(ClientData dummy,Tcl_Interp *interp,
			    int objc, Tcl_Obj *const objv[]);
static int		NamespaceParentCmd(ClientData dummy,Tcl_Interp *interp,
................................................................................
    {"delete",	   NamespaceDeleteCmd,	TclCompileBasicMin0ArgCmd, NULL, NULL, 0},
    {"ensemble",   TclNamespaceEnsembleCmd, NULL, NULL, NULL, 0},
    {"eval",	   NamespaceEvalCmd,	NULL, NRNamespaceEvalCmd, NULL, 0},
    {"exists",	   NamespaceExistsCmd,	TclCompileBasic1ArgCmd, NULL, NULL, 0},
    {"export",	   NamespaceExportCmd,	TclCompileBasicMin0ArgCmd, NULL, NULL, 0},
    {"forget",	   NamespaceForgetCmd,	TclCompileBasicMin0ArgCmd, NULL, NULL, 0},
    {"import",	   NamespaceImportCmd,	TclCompileBasicMin0ArgCmd, NULL, NULL, 0},

    {"inscope",	   NamespaceInscopeCmd,	NULL, NRNamespaceInscopeCmd, NULL, 0},
    {"origin",	   NamespaceOriginCmd,	TclCompileNamespaceOriginCmd, NULL, NULL, 0},
    {"parent",	   NamespaceParentCmd,	TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
    {"path",	   NamespacePathCmd,	TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
    {"qualifiers", NamespaceQualifiersCmd, TclCompileNamespaceQualifiersCmd, NULL, NULL, 0},
    {"tail",	   NamespaceTailCmd,	TclCompileNamespaceTailCmd, NULL, NULL, 0},
    {"unknown",	   NamespaceUnknownCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
................................................................................
	result = Tcl_Import(interp, NULL, pattern, allowOverwrite);
	if (result != TCL_OK) {
	    return result;
	}
    }
    return TCL_OK;
}














































































































 
/*
 *----------------------------------------------------------------------
 *
 * NamespaceInscopeCmd --
 *
 *	Invoked to implement the "namespace inscope" command that executes a






>
>
>
>







 







>







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
...
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
....
3757
3758
3759
3760
3761
3762
3763
3764
3765
3766
3767
3768
3769
3770
3771
3772
3773
3774
3775
3776
3777
3778
3779
3780
3781
3782
3783
3784
3785
3786
3787
3788
3789
3790
3791
3792
3793
3794
3795
3796
3797
3798
3799
3800
3801
3802
3803
3804
3805
3806
3807
3808
3809
3810
3811
3812
3813
3814
3815
3816
3817
3818
3819
3820
3821
3822
3823
3824
3825
3826
3827
3828
3829
3830
3831
3832
3833
3834
3835
3836
3837
3838
3839
3840
3841
3842
3843
3844
3845
3846
3847
3848
3849
3850
3851
3852
3853
3854
3855
3856
3857
3858
3859
3860
3861
3862
3863
3864
3865
3866
3867
3868
3869
3870
3871
3872
3873
3874
3875
3876
3877
3878
3879
3880
static int		NamespaceExportCmd(ClientData dummy,Tcl_Interp *interp,
			    int objc, Tcl_Obj *const objv[]);
static int		NamespaceForgetCmd(ClientData dummy,Tcl_Interp *interp,
			    int objc, Tcl_Obj *const objv[]);
static void		NamespaceFree(Namespace *nsPtr);
static int		NamespaceImportCmd(ClientData dummy,Tcl_Interp *interp,
			    int objc, Tcl_Obj *const objv[]);
static int		NamespaceInvokeCmd(ClientData dummy,Tcl_Interp *interp,
			    int objc, Tcl_Obj *const objv[]);
static int		NRNamespaceInvokeCmd(ClientData dummy,
			    Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
static int		NamespaceInscopeCmd(ClientData dummy,
			    Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
static int		NRNamespaceInscopeCmd(ClientData dummy,
			    Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
static int		NamespaceOriginCmd(ClientData dummy,Tcl_Interp *interp,
			    int objc, Tcl_Obj *const objv[]);
static int		NamespaceParentCmd(ClientData dummy,Tcl_Interp *interp,
................................................................................
    {"delete",	   NamespaceDeleteCmd,	TclCompileBasicMin0ArgCmd, NULL, NULL, 0},
    {"ensemble",   TclNamespaceEnsembleCmd, NULL, NULL, NULL, 0},
    {"eval",	   NamespaceEvalCmd,	NULL, NRNamespaceEvalCmd, NULL, 0},
    {"exists",	   NamespaceExistsCmd,	TclCompileBasic1ArgCmd, NULL, NULL, 0},
    {"export",	   NamespaceExportCmd,	TclCompileBasicMin0ArgCmd, NULL, NULL, 0},
    {"forget",	   NamespaceForgetCmd,	TclCompileBasicMin0ArgCmd, NULL, NULL, 0},
    {"import",	   NamespaceImportCmd,	TclCompileBasicMin0ArgCmd, NULL, NULL, 0},
    {"invoke",	   NamespaceInvokeCmd,	TclCompileBasicMin2ArgCmd, NRNamespaceInvokeCmd, NULL, 0},
    {"inscope",	   NamespaceInscopeCmd,	NULL, NRNamespaceInscopeCmd, NULL, 0},
    {"origin",	   NamespaceOriginCmd,	TclCompileNamespaceOriginCmd, NULL, NULL, 0},
    {"parent",	   NamespaceParentCmd,	TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
    {"path",	   NamespacePathCmd,	TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
    {"qualifiers", NamespaceQualifiersCmd, TclCompileNamespaceQualifiersCmd, NULL, NULL, 0},
    {"tail",	   NamespaceTailCmd,	TclCompileNamespaceTailCmd, NULL, NULL, 0},
    {"unknown",	   NamespaceUnknownCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
................................................................................
	result = Tcl_Import(interp, NULL, pattern, allowOverwrite);
	if (result != TCL_OK) {
	    return result;
	}
    }
    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *
 * NamespaceInvokeCmd --
 *
 *	Invoked to implement the "namespace invoke" command that invokes a
 *	command in a predefined namespace. Handles the syntax:
 *
 *	    namespace invoke ns cmd ?arg1? ?arg2? ...
 *
 *      This invokes the command cmd, as resolved from namespace ns, with the
 *      supplied arguments. It is similar to:
 *
 *          namespace eval ns [list cmd ?arg1? ?arg2? ...]
 *
 *      up to the fact that it executes in the caller's context: it does *not*
 *      push a new CallFrame.
 *
 * Results:
 *	Returns TCL_OK if the namespace is found and the command is executed
 *	successfully. Returns TCL_ERROR if anything goes wrong.
 *
 * Side effects:
 *	Returns the result of the command in the interpreter's result object.
 *	If anything goes wrong, this function returns an error message as the
 *	result.
 *
 *----------------------------------------------------------------------
 */

static int
NamespaceInvokeCmd(
    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Interp *iPtr = (Interp *) interp;
    Tcl_Namespace *namespacePtr;
    int result;

    if (objc < 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "name cmd ?arg...?");
	return TCL_ERROR;
    }

    /*
     * Try to resolve the namespace reference, caching the result in the
     * namespace object along the way. If the namespace is not found, return
     * an error.
     */

    result = TclGetNamespaceFromObj(interp, objv[1], &namespacePtr);
    if (result != TCL_OK) {
	return result;
    }
    if (namespacePtr == NULL) {
	Tcl_AppendResult(interp, "unknown namespace \"",
		Tcl_GetString(objv[1]), "\"", NULL);
	return TCL_ERROR;
    }

    /*
     * Invoke the command in the requested namespace
     */

    iPtr->lookupNsPtr = (Namespace *) namespacePtr;
    return Tcl_EvalObjv(interp, objc - 2, objv + 2, TCL_EVAL_INVOKE);
}

static int
NRNamespaceInvokeCmd(
    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Interp *iPtr = (Interp *) interp;
    Tcl_Namespace *namespacePtr;
    int result;

    if (objc < 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "name cmd ?arg...?");
	return TCL_ERROR;
    }

    /*
     * Try to resolve the namespace reference, caching the result in the
     * namespace object along the way. If the namespace is not found, return
     * an error.
     */

    result = TclGetNamespaceFromObj(interp, objv[1], &namespacePtr);
    if (result != TCL_OK) {
	return result;
    }
    if (namespacePtr == NULL) {
	Tcl_AppendResult(interp, "unknown namespace \"",
		Tcl_GetString(objv[1]), "\"", NULL);
	return TCL_ERROR;
    }

    /*
     * Invoke the command in the requested namespace
     */

    iPtr->lookupNsPtr = (Namespace *) namespacePtr;
    return TclNREvalObjv(interp, objc - 2, objv + 2, TCL_EVAL_INVOKE, NULL);
}
 
/*
 *----------------------------------------------------------------------
 *
 * NamespaceInscopeCmd --
 *
 *	Invoked to implement the "namespace inscope" command that executes a

Changes to generic/tclProc.c.

714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
...
861
862
863
864
865
866
867

868
869
870

871
872
873
874
875
876
877
878
...
950
951
952
953
954
955
956
957
958
959
960
















































































961
962
963
964
965
966
967
int
TclGetFrame(
    Tcl_Interp *interp,		/* Interpreter in which to find frame. */
    const char *name,		/* String describing frame. */
    CallFrame **framePtrPtr)	/* Store pointer to frame here (or NULL if
				 * global frame indicated). */
{
	int result;
	Tcl_Obj obj;

	obj.bytes = (char *) name;
	obj.length = strlen(name);
	obj.typePtr = NULL;
	result = TclObjGetFrame(interp, &obj, framePtrPtr);
	TclFreeIntRep(&obj);
	return result;
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclObjGetFrame --
 *
................................................................................
static int
Uplevel_Callback(
    ClientData data[],
    Tcl_Interp *interp,
    int result)
{
    CallFrame *savedVarFramePtr = data[0];


    if (result == TCL_ERROR) {
	Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(

		"\n    (\"uplevel\" body line %d)", Tcl_GetErrorLine(interp)));
    }

    /*
     * Restore the variable frame, and return.
     */

    ((Interp *)interp)->varFramePtr = savedVarFramePtr;
................................................................................
	 * between, then evaluate the result. Tcl_EvalObjEx will delete the
	 * object when it decrements its refcount after eval'ing it.
	 */

	objPtr = Tcl_ConcatObj(objc, objv);
    }

    TclNRAddCallback(interp, Uplevel_Callback, savedVarFramePtr, NULL, NULL,
	    NULL);
    return TclNREvalObjEx(interp, objPtr, 0, invoker, word);
}
















































































 
/*
 *----------------------------------------------------------------------
 *
 * TclFindProc --
 *
 *	Given the name of a procedure, return a pointer to the record






|
|

|
|
|
|
|
|







 







>



>
|







 







|
|


>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
...
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
...
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
int
TclGetFrame(
    Tcl_Interp *interp,		/* Interpreter in which to find frame. */
    const char *name,		/* String describing frame. */
    CallFrame **framePtrPtr)	/* Store pointer to frame here (or NULL if
				 * global frame indicated). */
{
    int result;
    Tcl_Obj obj;

    obj.bytes = (char *) name;
    obj.length = strlen(name);
    obj.typePtr = NULL;
    result = TclObjGetFrame(interp, &obj, framePtrPtr);
    TclFreeIntRep(&obj);
    return result;
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclObjGetFrame --
 *
................................................................................
static int
Uplevel_Callback(
    ClientData data[],
    Tcl_Interp *interp,
    int result)
{
    CallFrame *savedVarFramePtr = data[0];
    const char *msgPiece = data[1];

    if (result == TCL_ERROR) {
	Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
		"\n    (\"%s\" body line %d)",
		msgPiece, Tcl_GetErrorLine(interp)));
    }

    /*
     * Restore the variable frame, and return.
     */

    ((Interp *)interp)->varFramePtr = savedVarFramePtr;
................................................................................
	 * between, then evaluate the result. Tcl_EvalObjEx will delete the
	 * object when it decrements its refcount after eval'ing it.
	 */

	objPtr = Tcl_ConcatObj(objc, objv);
    }

    TclNRAddCallback(interp, Uplevel_Callback, savedVarFramePtr, "uplevel",
	    NULL, NULL);
    return TclNREvalObjEx(interp, objPtr, 0, invoker, word);
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_InvokeObjCmd --
 *
 *	This object function is invoked to process the "invoke" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl object result value.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_InvokeObjCmd(
    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    return Tcl_NRCallObjProc(interp, TclNRInvokeObjCmd, dummy, objc, objv);
}

int
TclNRInvokeObjCmd(
    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    register Interp *iPtr = (Interp *) interp;
    int result;
    CallFrame *savedVarFramePtr, *framePtr;

    if (objc < 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "level command ?arg ...?");
	return TCL_ERROR;
    }

    /*
     * Find the level to use for executing the command.
     */

    result = TclObjGetFrame(interp, objv[1], &framePtr);
    if (result == -1) {
	return TCL_ERROR;
    } else if (result == 0) {
	/*
	 * Must have a level, and whatever we've got, that's what we haven't
	 * got.
	 */

	const char *name = TclGetString(objv[1]);

	Tcl_SetObjResult(interp, Tcl_ObjPrintf("bad level \"%s\"", name));
	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LEVEL", name, NULL);
	return TCL_ERROR;
    }

    /*
     * Modify the interpreter state to execute in the given frame.
     */

    savedVarFramePtr = iPtr->varFramePtr;
    iPtr->varFramePtr = framePtr;

    /*
     * Execute the residual arguments as a command.
     */

    TclNRAddCallback(interp, Uplevel_Callback, savedVarFramePtr, "invoke",
	    NULL, NULL);
    return TclNREvalObjv(interp, objc - 2, objv + 2, TCL_EVAL_INVOKE, NULL);
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclFindProc --
 *
 *	Given the name of a procedure, return a pointer to the record

Changes to tests/namespace.test.

3319
3320
3321
3322
3323
3324
3325














































































3326
3327
3328
3329
3330
3331
3332
3333
3334
3335
3336
3337
3338
    proc p1 {} {
	    return 16fe1b5807
    }
}

: p1
} 16fe1b5807














































































 
# cleanup
catch {rename cmd1 {}}
catch {unset l}
catch {unset msg}
catch {unset trigger}
namespace delete {*}[namespace children :: test_ns_*]
::tcltest::cleanupTests
return

# Local Variables:
# mode: tcl
# End:






>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>













3319
3320
3321
3322
3323
3324
3325
3326
3327
3328
3329
3330
3331
3332
3333
3334
3335
3336
3337
3338
3339
3340
3341
3342
3343
3344
3345
3346
3347
3348
3349
3350
3351
3352
3353
3354
3355
3356
3357
3358
3359
3360
3361
3362
3363
3364
3365
3366
3367
3368
3369
3370
3371
3372
3373
3374
3375
3376
3377
3378
3379
3380
3381
3382
3383
3384
3385
3386
3387
3388
3389
3390
3391
3392
3393
3394
3395
3396
3397
3398
3399
3400
3401
3402
3403
3404
3405
3406
3407
3408
3409
3410
3411
3412
3413
3414
3415
3416
    proc p1 {} {
	    return 16fe1b5807
    }
}

: p1
} 16fe1b5807

namespace eval ::namespace-57 {
test namespace-57.1 {namespace invoke} -returnCodes error -body {
    namespace invoke
} -result {wrong # args: should be "namespace invoke name cmd ?arg...?"}
test namespace-57.2 {namespace invoke} -returnCodes error -body {
    namespace invoke no_such_namespace namespace current
} -result {namespace "no_such_namespace" not found in "::namespace-57"}
test namespace-57.3 {namespace invoke} -returnCodes error -body {
    namespace invoke :: definitely_no_such_command
} -result {invalid command name "definitely_no_such_command"}
test namespace-57.4 {namespace invoke doesn't push a namespace} -body {
    namespace invoke :: namespace current
} -result ::namespace-57
test namespace-57.5 {namespace invoke resolves in the given ns} -setup {
    namespace eval ns {}
} -body {
    proc target {} {return "in origin"}
    proc ns::target {} {return "in target"}
    namespace invoke ns target
} -cleanup {
    rename target {}
    namespace delete ns
} -result {in target}
test namespace-57.6 {namespace invoke resolves in the given ns} -setup {
    namespace eval ns {}
} -body {
    namespace eval ns::tcl {}
    namespace invoke ns tcl::prefix match {a bcd e} b
} -cleanup {
    namespace delete ns
} -result bcd
test namespace-57.7 {namespace invoke resolves in the given ns} -setup {
    namespace eval ns {}
} -body {
    namespace eval ns::tcl {proc prefix args {return ok}}
    namespace invoke ns tcl::prefix match {a bcd e} b
} -cleanup {
    namespace delete ns
} -result ok
test namespace-57.8 {namespace invoke resolves in the given ns} -setup {
    namespace eval ns {}
    namespace eval ns2 {
	proc foo {} {return "this is in ns2"}
    }
} -body {
    namespace eval ns {
	namespace path ::namespace-57::ns2
    }
    namespace invoke ns foo
} -cleanup {
    namespace delete ns
} -result {this is in ns2}
test namespace-57.9 {namespace invoke preserves word boundaries} -setup {
    namespace eval ns {
	proc count args {list [llength $args] $args}
    }
} -body {
    namespace invoke ns count a {b c} gorp
} -cleanup {
    namespace delete ns
} -result {3 {a {b c} gorp}}
test namespace-57.10 {namespace invoke is NRE-aware} -setup {
    namespace eval ns {}
} -body {
    proc ns::count args {
	yield $args
	return [llength $args]
    }
    coroutine c apply {args {
	yield
	namespace invoke ns count {*}$args
    } ::namespace-57} a {b c} gorp
    list [c] [c]
} -cleanup {
    namespace delete ns
} -result {{a {b c} gorp} 3}
}
 
# cleanup
catch {rename cmd1 {}}
catch {unset l}
catch {unset msg}
catch {unset trigger}
namespace delete {*}[namespace children :: test_ns_*]
::tcltest::cleanupTests
return

# Local Variables:
# mode: tcl
# End:

Changes to tests/uplevel.test.

1
2
3
4
5
6
7
8
...
290
291
292
293
294
295
296





































297
298
299
300
301
302
303
304
305
# Commands covered:  uplevel
#
# This file contains a collection of tests for one or more of the Tcl built-in
# commands.  Sourcing this file into Tcl runs the tests and generates output
# for errors.  No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
................................................................................
    }
    foo
    moo
} -cleanup {
    rename foo {}
    rename moo {}
} -result {3 3 3}





































 
# cleanup
::tcltest::cleanupTests
return

# Local Variables:
# mode: tcl
# fill-column: 78
# End:
|







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>









1
2
3
4
5
6
7
8
...
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
# Commands covered:  uplevel, invoke
#
# This file contains a collection of tests for one or more of the Tcl built-in
# commands.  Sourcing this file into Tcl runs the tests and generates output
# for errors.  No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
................................................................................
    }
    foo
    moo
} -cleanup {
    rename foo {}
    rename moo {}
} -result {3 3 3}

test invoke-1.1 {invoke command usage} -returnCodes error -body {
    invoke
} -result {wrong # args: should be "invoke level command ?arg ...?"}
test invoke-1.2 {invoke command usage} -returnCodes error -body {
    invoke 0
} -result {wrong # args: should be "invoke level command ?arg ...?"}
test invoke-1.3 {invoke command usage} -returnCodes error -body {
    invoke list a b c
} -result {bad level "list"}
test invoke-1.4 {invoke command usage} -returnCodes error -body {
    invoke 50000 list a b c
} -result {bad level "50000"}
test invoke-1.5 {invoke preserves word boundaries} -body {
    invoke 0 list "a b" c
} -result {{a b} c}
test invoke-1.6 {invoke walks the stack} -body {
    apply {x {
	apply {x {
	    apply {x {
		apply {{x levels} {
		    lmap l $levels {string cat $l -> [invoke $l set x]}
		}} jkl {3 2 1 0 #1 #2 #3 #4}
	    }} ghi
	}} def
    }} abc
} -result {3->abc 2->def 1->ghi 0->jkl #1->abc #2->def #3->ghi #4->jkl}
test invoke-1.7 {invoke is NRE-aware} -body {
    coroutine c apply {{} {
	set x [yield]
	list [apply {x {
	    invoke 1 eval {set x [yield $x]}
	    return $x
	}} $x,$x] $x
    }}
    list [c 135] [c 246]
} -result {135 {135,135 246}}
 
# cleanup
::tcltest::cleanupTests
return

# Local Variables:
# mode: tcl
# fill-column: 78
# End: