summaryrefslogtreecommitdiffstats
path: root/generic/tclTestProcBodyObj.c
blob: b961e3cf1a19755cab89dc0fb0078bb38b683d5e (plain)
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
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
/*
 * tclTestProcBodyObj.c --
 *
 *	Implements the "procbodytest" package, which contains commands to test
 *	creation of Tcl procedures whose body argument is a Tcl_Obj of type
 *	"procbody" rather than a string.
 *
 * Copyright (c) 1998 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclTestProcBodyObj.c,v 1.9 2009/02/10 23:08:56 nijtmans Exp $
 */

#include "tclInt.h"

/*
 * name and version of this package
 */

static char packageName[] = "procbodytest";
static char packageVersion[] = "1.0";

/*
 * Name of the commands exported by this package
 */

static char procCommand[] = "proc";

/*
 * this struct describes an entry in the table of command names and command
 * procs
 */

typedef struct CmdTable {
    char *cmdName;		/* command name */
    Tcl_ObjCmdProc *proc;	/* command proc */
    int exportIt;		/* if 1, export the command */
} CmdTable;

/*
 * Declarations for functions defined in this file.
 */

static int	ProcBodyTestProcObjCmd(ClientData dummy,
			Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
static int	ProcBodyTestInitInternal(Tcl_Interp *interp, int isSafe);
static int	RegisterCommand(Tcl_Interp* interp,
			char *namespace, const CmdTable *cmdTablePtr);
int		Procbodytest_Init(Tcl_Interp * interp);
int		Procbodytest_SafeInit(Tcl_Interp * interp);

/*
 * List of commands to create when the package is loaded; must go after the
 * declarations of the enable command procedure.
 */

static const CmdTable commands[] = {
    { procCommand,	ProcBodyTestProcObjCmd,	1 },
    { 0, 0, 0 }
};

static const CmdTable safeCommands[] = {
    { procCommand,	ProcBodyTestProcObjCmd,	1 },
    { 0, 0, 0 }
};

/*
 *----------------------------------------------------------------------
 *
 * Procbodytest_Init --
 *
 *	This function initializes the "procbodytest" package.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Procbodytest_Init(
    Tcl_Interp *interp)		/* the Tcl interpreter for which the package
				 * is initialized */
{
    return ProcBodyTestInitInternal(interp, 0);
}

/*
 *----------------------------------------------------------------------
 *
 * Procbodytest_SafeInit --
 *
 *	This function initializes the "procbodytest" package.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Procbodytest_SafeInit(
    Tcl_Interp *interp)		/* the Tcl interpreter for which the package
				 * is initialized */
{
    return ProcBodyTestInitInternal(interp, 1);
}

/*
 *----------------------------------------------------------------------
 *
 * RegisterCommand --
 *
 *	This function registers a command in the context of the given
 *	namespace.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
RegisterCommand(
    Tcl_Interp* interp,		/* the Tcl interpreter for which the operation
				 * is performed */
    char *namespace,		/* the namespace in which the command is
				 * registered */
    const CmdTable *cmdTablePtr)/* the command to register */
{
    char buf[128];

    if (cmdTablePtr->exportIt) {
	sprintf(buf, "namespace eval %s { namespace export %s }",
		namespace, cmdTablePtr->cmdName);
	if (Tcl_Eval(interp, buf) != TCL_OK) {
	    return TCL_ERROR;
	}
    }

    sprintf(buf, "%s::%s", namespace, cmdTablePtr->cmdName);
    Tcl_CreateObjCommand(interp, buf, cmdTablePtr->proc, 0, 0);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * ProcBodyTestInitInternal --
 *
 *  This function initializes the Loader package.
 *  The isSafe flag is 1 if the interpreter is safe, 0 otherwise.
 *
 * Results:
 *  A standard Tcl result.
 *
 * Side effects:
 *  None.
 *
 *----------------------------------------------------------------------
 */

static int
ProcBodyTestInitInternal(
    Tcl_Interp *interp,		/* the Tcl interpreter for which the package
				 * is initialized */
    int isSafe)			/* 1 if this is a safe interpreter */
{
    const CmdTable *cmdTablePtr;

    cmdTablePtr = (isSafe) ? &safeCommands[0] : &commands[0];
    for ( ; cmdTablePtr->cmdName ; cmdTablePtr++) {
	if (RegisterCommand(interp, packageName, cmdTablePtr) != TCL_OK) {
	    return TCL_ERROR;
	}
    }

    return Tcl_PkgProvide(interp, packageName, packageVersion);
}

/*
 *----------------------------------------------------------------------
 *
 * ProcBodyTestProcObjCmd --
 *
 *  Implements the "procbodytest::proc" command. Here is the command
 *  description:
 *	procbodytest::proc newName argList bodyName
 *  Looks up a procedure called $bodyName and, if the procedure exists,
 *  constructs a Tcl_Obj of type "procbody" and calls Tcl_ProcObjCmd.
 *  Arguments:
 *    newName		the name of the procedure to be created
 *    argList		the argument list for the procedure
 *    bodyName		the name of an existing procedure from which the
 *			body is to be copied.
 *  This command can be used to trigger the branches in Tcl_ProcObjCmd that
 *  construct a proc from a "procbody", for example:
 *	proc a {x} {return $x}
 *	a 123
 *	procbodytest::proc b {x} a
 *  Note the call to "a 123", which is necessary so that the Proc pointer
 *  for "a" is filled in by the internal compiler; this is a hack.
 *
 * Results:
 *  Returns a standard Tcl code.
 *
 * Side effects:
 *  A new procedure is created.
 *  Leaves an error message in the interp's result on error.
 *
 *----------------------------------------------------------------------
 */

static int
ProcBodyTestProcObjCmd(
    ClientData dummy,		/* context; not used */
    Tcl_Interp *interp,		/* the current interpreter */
    int objc,			/* argument count */
    Tcl_Obj *const objv[])	/* arguments */
{
    const char *fullName;
    Tcl_Command procCmd;
    Command *cmdPtr;
    Proc *procPtr = NULL;
    Tcl_Obj *bodyObjPtr;
    Tcl_Obj *myobjv[5];
    int result;

    if (objc != 4) {
	Tcl_WrongNumArgs(interp, 1, objv, "newName argsList bodyName");
	return TCL_ERROR;
    }

    /*
     * Find the Command pointer to this procedure
     */

    fullName = Tcl_GetStringFromObj(objv[3], NULL);
    procCmd = Tcl_FindCommand(interp, fullName, NULL, TCL_LEAVE_ERR_MSG);
    if (procCmd == NULL) {
	return TCL_ERROR;
    }

    cmdPtr = (Command *) procCmd;

    /*
     * check that this is a procedure and not a builtin command:
     * If a procedure, cmdPtr->objClientData is TclIsProc(cmdPtr).
     */

    if (cmdPtr->objClientData != TclIsProc(cmdPtr)) {
	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
		"command \"", fullName, "\" is not a Tcl procedure", NULL);
	return TCL_ERROR;
    }

    /*
     * it is a Tcl procedure: the client data is the Proc structure
     */

    procPtr = (Proc *) cmdPtr->objClientData;
    if (procPtr == NULL) {
	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "procedure \"",
		fullName, "\" does not have a Proc struct!", NULL);
	return TCL_ERROR;
    }

    /*
     * create a new object, initialize our argument vector, call into Tcl
     */

    bodyObjPtr = TclNewProcBodyObj(procPtr);
    if (bodyObjPtr == NULL) {
	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
		"failed to create a procbody object for procedure \"",
		fullName, "\"", NULL);
	return TCL_ERROR;
    }
    Tcl_IncrRefCount(bodyObjPtr);

    myobjv[0] = objv[0];
    myobjv[1] = objv[1];
    myobjv[2] = objv[2];
    myobjv[3] = bodyObjPtr;
    myobjv[4] = NULL;

    result = Tcl_ProcObjCmd((ClientData) NULL, interp, objc, myobjv);
    Tcl_DecrRefCount(bodyObjPtr);

    return result;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */