1
2
3
4
5
6
7
8
9
10
11
12
13
14
|
/*
** This file contains code used to bridge the TH1 and Tcl scripting languages.
*/
#include "config.h"
#include "th.h"
#include "tcl.h"
/*
** Syntax:
**
** tclEval arg ?arg ...?
*/
static int tclEval_command(
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
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
|
/*
** This file contains code used to bridge the TH1 and Tcl scripting languages.
*/
#include "config.h"
#include "th.h"
#include "tcl.h"
/*
** These macros are designed to reduce the redundant code required to marshal
** arguments from TH1 to Tcl.
*/
#define USE_ARGV_TO_OBJV() \
int objc; \
Tcl_Obj **objv; \
int i;
#define COPY_ARGV_TO_OBJV() \
objc = argc-1; \
objv = (Tcl_Obj **)ckalloc((unsigned)(objc * sizeof(Tcl_Obj *))); \
for(i=1; i<argc; i++){ \
objv[i-1] = Tcl_NewStringObj(argv[i], argl[i]); \
Tcl_IncrRefCount(objv[i-1]); \
}
#define FREE_ARGV_TO_OBJV() \
for(i=1; i<argc; i++){ \
Tcl_DecrRefCount(objv[i-1]); \
} \
ckfree((char *)objv);
/*
** Returns the Tcl interpreter result as a string with the associated length.
** If the Tcl interpreter or the Tcl result are NULL, the length will be 0.
** If the length pointer is NULL, the length will not be stored.
*/
static char *getTclResult(Tcl_Interp *pInterp, int *pN){
Tcl_Obj *resultPtr;
if( !pInterp ){ /* This should not happen. */
if( pN ) *pN = 0;
return 0;
}
resultPtr = Tcl_GetObjResult(pInterp);
if( !resultPtr ){ /* This should not happen either? */
if( pN ) *pN = 0;
return 0;
}
return Tcl_GetStringFromObj(resultPtr, pN);
}
/*
** Syntax:
**
** tclEval arg ?arg ...?
*/
static int tclEval_command(
|
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
|
int nResult;
const char *zResult;
if( argc<2 ){
return Th_WrongNumArgs(interp, "tclEval arg ?arg ...?");
}
tclInterp = (Tcl_Interp *)ctx;
if( !tclInterp ){
Th_ErrorMessage(interp, "invalid Tcl interpreter", (const char *)"", 0);
return TH_ERROR;
}
if( argc==2 ){
objPtr = Tcl_NewStringObj(argv[1], argl[1]);
Tcl_IncrRefCount(objPtr);
rc = Tcl_EvalObjEx(tclInterp, objPtr, 0);
Tcl_DecrRefCount(objPtr);
}else{
int objc = argc-1;
Tcl_Obj **objv = (Tcl_Obj **)ckalloc((unsigned)(objc * sizeof(Tcl_Obj *)));
int i;
for(i=1; i<argc; i++){
objv[i-1] = Tcl_NewStringObj(argv[i], argl[i]);
Tcl_IncrRefCount(objv[i-1]);
}
objPtr = Tcl_ConcatObj(objc, objv);
Tcl_IncrRefCount(objPtr);
rc = Tcl_EvalObjEx(tclInterp, objPtr, 0);
Tcl_DecrRefCount(objPtr);
for(i=1; i<argc; i++){
Tcl_DecrRefCount(objv[i-1]);
}
ckfree((char *)objv);
}
objPtr = Tcl_GetObjResult(tclInterp);
zResult = Tcl_GetStringFromObj(objPtr, &nResult);
Th_SetResult(interp, zResult, nResult);
return rc;
}
/*
** Syntax:
**
** tclExpr arg ?arg ...?
|
|
>
<
>
|
<
<
<
<
<
|
<
|
<
<
|
<
>
|
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
|
int nResult;
const char *zResult;
if( argc<2 ){
return Th_WrongNumArgs(interp, "tclEval arg ?arg ...?");
}
tclInterp = (Tcl_Interp *)ctx;
if( !tclInterp || Tcl_InterpDeleted(tclInterp) ){
Th_ErrorMessage(interp, "invalid Tcl interpreter", (const char *)"", 0);
return TH_ERROR;
}
Tcl_Preserve((ClientData)tclInterp);
if( argc==2 ){
objPtr = Tcl_NewStringObj(argv[1], argl[1]);
Tcl_IncrRefCount(objPtr);
rc = Tcl_EvalObjEx(tclInterp, objPtr, 0);
Tcl_DecrRefCount(objPtr);
}else{
USE_ARGV_TO_OBJV();
COPY_ARGV_TO_OBJV();
objPtr = Tcl_ConcatObj(objc, objv);
Tcl_IncrRefCount(objPtr);
rc = Tcl_EvalObjEx(tclInterp, objPtr, 0);
Tcl_DecrRefCount(objPtr);
FREE_ARGV_TO_OBJV();
}
zResult = getTclResult(tclInterp, &nResult);
Th_SetResult(interp, zResult, nResult);
Tcl_Release((ClientData)tclInterp);
return rc;
}
/*
** Syntax:
**
** tclExpr arg ?arg ...?
|
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
|
int nResult;
const char *zResult;
if( argc<2 ){
return Th_WrongNumArgs(interp, "tclExpr arg ?arg ...?");
}
tclInterp = (Tcl_Interp *)ctx;
if( !tclInterp ){
Th_ErrorMessage(interp, "invalid Tcl interpreter", (const char *)"", 0);
return TH_ERROR;
}
if( argc==2 ){
objPtr = Tcl_NewStringObj(argv[1], argl[1]);
Tcl_IncrRefCount(objPtr);
rc = Tcl_ExprObj(tclInterp, objPtr, &resultObjPtr);
Tcl_DecrRefCount(objPtr);
}else{
int objc = argc-1;
Tcl_Obj **objv = (Tcl_Obj **)ckalloc((unsigned)(objc * sizeof(Tcl_Obj *)));
int i;
for(i=1; i<argc; i++){
objv[i-1] = Tcl_NewStringObj(argv[i], argl[i]);
Tcl_IncrRefCount(objv[i-1]);
}
objPtr = Tcl_ConcatObj(objc, objv);
Tcl_IncrRefCount(objPtr);
rc = Tcl_ExprObj(tclInterp, objPtr, &resultObjPtr);
Tcl_DecrRefCount(objPtr);
for(i=1; i<argc; i++){
Tcl_DecrRefCount(objv[i-1]);
}
ckfree((char *)objv);
}
zResult = Tcl_GetStringFromObj(resultObjPtr, &nResult);
Tcl_DecrRefCount(resultObjPtr);
return rc;
}
/*
** Syntax:
**
** tclInvoke command ?arg ...?
*/
static int tclInvoke_command(
Th_Interp *interp,
void *ctx,
int argc,
const char **argv,
int *argl
){
Tcl_Interp *tclInterp;
Tcl_CmdInfo cmdInfo;
int objc;
Tcl_Obj **objv;
int i;
if( !tclInterp ){
Th_ErrorMessage(interp, "invalid Tcl interpreter", (const char *)"", 0);
return TH_ERROR;
}
if (Tcl_GetCommandInfo(tclInterp, argv[1], &cmdInfo) == 0){
Th_ErrorMessage(interp, "Tcl command not found:", argv[1], argl[1]);
return TH_ERROR;
}
objc = argc-1;
objv = (Tcl_Obj **)ckalloc((unsigned)(objc * sizeof(Tcl_Obj *)));
for(i=1; i<argc; i++){
objv[i-1] = Tcl_NewStringObj(argv[i], argl[i]);
Tcl_IncrRefCount(objv[i-1]);
}
Tcl_Preserve((ClientData)tclInterp);
for(i=1; i<argc; i++){
Tcl_DecrRefCount(objv[i-1]);
}
ckfree((char *)objv);
objPtr = Tcl_GetObjResult(tclInterp);
zResult = Tcl_GetStringFromObj(objPtr, &nResult);
|
|
>
<
>
|
<
<
<
<
<
|
<
|
>
|
>
>
<
|
>
>
<
<
<
>
|
>
>
>
>
|
>
>
<
<
<
<
|
<
<
>
<
|
<
<
|
<
|
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
|
int nResult;
const char *zResult;
if( argc<2 ){
return Th_WrongNumArgs(interp, "tclExpr arg ?arg ...?");
}
tclInterp = (Tcl_Interp *)ctx;
if( !tclInterp || Tcl_InterpDeleted(tclInterp) ){
Th_ErrorMessage(interp, "invalid Tcl interpreter", (const char *)"", 0);
return TH_ERROR;
}
Tcl_Preserve((ClientData)tclInterp);
if( argc==2 ){
objPtr = Tcl_NewStringObj(argv[1], argl[1]);
Tcl_IncrRefCount(objPtr);
rc = Tcl_ExprObj(tclInterp, objPtr, &resultObjPtr);
Tcl_DecrRefCount(objPtr);
}else{
USE_ARGV_TO_OBJV();
COPY_ARGV_TO_OBJV();
objPtr = Tcl_ConcatObj(objc, objv);
Tcl_IncrRefCount(objPtr);
rc = Tcl_ExprObj(tclInterp, objPtr, &resultObjPtr);
Tcl_DecrRefCount(objPtr);
FREE_ARGV_TO_OBJV();
}
if( rc==TCL_OK ){
zResult = Tcl_GetStringFromObj(resultObjPtr, &nResult);
}else{
zResult = getTclResult(tclInterp, &nResult);
}
Th_SetResult(interp, zResult, nResult);
if( rc==TCL_OK ) Tcl_DecrRefCount(resultObjPtr);
Tcl_Release((ClientData)tclInterp);
return rc;
}
/*
** Syntax:
**
** tclInvoke command ?arg ...?
*/
static int tclInvoke_command(
Th_Interp *interp,
void *ctx,
int argc,
const char **argv,
int *argl
){
Tcl_Interp *tclInterp;
Tcl_Command command;
Tcl_CmdInfo cmdInfo;
int rc;
int nResult;
const char *zResult;
Tcl_Obj *objPtr;
USE_ARGV_TO_OBJV();
if( argc<2 ){
return Th_WrongNumArgs(interp, "tclInvoke command ?arg ...?");
}
tclInterp = (Tcl_Interp *)ctx;
if( !tclInterp || Tcl_InterpDeleted(tclInterp) ){
Th_ErrorMessage(interp, "invalid Tcl interpreter", (const char *)"", 0);
return TH_ERROR;
}
Tcl_Preserve((ClientData)tclInterp);
objPtr = Tcl_NewStringObj(argv[1], argl[1]);
Tcl_IncrRefCount(objPtr);
command = Tcl_GetCommandFromObj(tclInterp, objPtr);
if( !command || Tcl_GetCommandInfoFromToken(command,&cmdInfo)==0 ){
Th_ErrorMessage(interp, "Tcl command not found:", argv[1], argl[1]);
Tcl_DecrRefCount(objPtr);
Tcl_Release((ClientData)tclInterp);
return TH_ERROR;
}
Tcl_DecrRefCount(objPtr);
COPY_ARGV_TO_OBJV();
Tcl_ResetResult(tclInterp);
rc = cmdInfo.objProc(cmdInfo.objClientData, tclInterp, objc, objv);
FREE_ARGV_TO_OBJV();
zResult = getTclResult(tclInterp, &nResult);
Th_SetResult(interp, zResult, nResult);
Tcl_Release((ClientData)tclInterp);
return rc;
}
/*
** Syntax:
|
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
|
*/
static void Th1DeleteProc(
ClientData clientData,
Tcl_Interp *interp
){
int i;
Th_Interp *th1Interp = (Th_Interp *)clientData;
if ( !th1Interp ) return;
/* Remove the Tcl integration commands. */
for(i=0; i<(sizeof(aCommand)/sizeof(aCommand[0])); i++){
Th_RenameCommand(th1Interp, aCommand[i].zName, -1, NULL, 0);
}
}
/*
** Register the Tcl language commands with interpreter interp.
** Usually this is called soon after interpreter creation.
*/
int th_register_tcl(Th_Interp *interp){
int i;
Tcl_Interp *tclInterp = Tcl_CreateInterp();
if( !tclInterp ){
Th_ErrorMessage(interp,
"Could not create Tcl interpreter", (const char *)"", 0);
return TH_ERROR;
}
if( Tcl_Init(tclInterp)!=TCL_OK ){
Th_ErrorMessage(interp,
"Tcl initialization error:", Tcl_GetStringResult(tclInterp), -1);
Tcl_DeleteInterp(tclInterp);
return TH_ERROR;
}
Tcl_CallWhenDeleted(tclInterp, Th1DeleteProc, interp);
Tcl_CreateObjCommand(tclInterp, "th1Eval", Th1EvalObjCmd, interp, NULL);
Tcl_CreateObjCommand(tclInterp, "th1Expr", Th1ExprObjCmd, interp, NULL);
/* Add the Tcl integration commands. */
for(i=0; i<(sizeof(aCommand)/sizeof(aCommand[0])); i++){
void *ctx = aCommand[i].pContext;
/* Use Tcl interpreter for context? */
if( !ctx ) ctx = tclInterp;
Th_CreateCommand(interp, aCommand[i].zName, aCommand[i].xProc, ctx, 0);
}
return TH_OK;
}
|
|
|
>
|
|
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
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
|
*/
static void Th1DeleteProc(
ClientData clientData,
Tcl_Interp *interp
){
int i;
Th_Interp *th1Interp = (Th_Interp *)clientData;
if( !th1Interp ) return;
/* Remove the Tcl integration commands. */
for(i=0; i<(sizeof(aCommand)/sizeof(aCommand[0])); i++){
Th_RenameCommand(th1Interp, aCommand[i].zName, -1, NULL, 0);
}
}
/*
** Register the Tcl language commands with interpreter interp.
** Usually this is called soon after interpreter creation.
*/
int th_register_tcl(Th_Interp *interp){
int i;
Tcl_Interp *tclInterp = Tcl_CreateInterp();
if( !tclInterp || Tcl_InterpDeleted(tclInterp) ){
Th_ErrorMessage(interp,
"Could not create Tcl interpreter", (const char *)"", 0);
return TH_ERROR;
}
if( Tcl_Init(tclInterp)!=TCL_OK ){
Th_ErrorMessage(interp,
"Tcl initialization error:", Tcl_GetStringResult(tclInterp), -1);
Tcl_DeleteInterp(tclInterp);
return TH_ERROR;
}
/* Add the TH1 integration commands to Tcl. */
Tcl_CallWhenDeleted(tclInterp, Th1DeleteProc, interp);
Tcl_CreateObjCommand(tclInterp, "th1Eval", Th1EvalObjCmd, interp, NULL);
Tcl_CreateObjCommand(tclInterp, "th1Expr", Th1ExprObjCmd, interp, NULL);
/* Add the Tcl integration commands to TH1. */
for(i=0; i<(sizeof(aCommand)/sizeof(aCommand[0])); i++){
void *ctx = aCommand[i].pContext;
/* Use Tcl interpreter for context? */
if( !ctx ) ctx = tclInterp;
Th_CreateCommand(interp, aCommand[i].zName, aCommand[i].xProc, ctx, 0);
}
return TH_OK;
}
|