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
|
#include "config.h"
#ifdef FOSSIL_ENABLE_TCL
#include "th.h"
#include "tcl.h"
/*
** Has the decision about whether or not to use Tcl_EvalObjv already been made
** via the Makefile?
*/
#if !defined(USE_TCL_EVALOBJV)
/*
** Are we being compiled against Tcl 8.6b1 or b2? This check is [mostly]
** wrong for at the following reason:
**
** 1. Technically, this check is completely useless when the stubs mechanism
** is in use. In that case, a runtime version check would be required and
** that has not been implemented.
**
** However, if a particular user compiles and runs against Tcl 8.6b1 or b2,
** this will cause a fallback to using the "conservative" method of directly
** invoking a Tcl command. In that case, potential crashes will be avoided if
** the user just so happened to compile or run against Tcl 8.6b1 or b2.
*/
#if (TCL_MAJOR_VERSION == 8) && (TCL_MINOR_VERSION == 6) && \
(TCL_RELEASE_LEVEL == TCL_BETA_RELEASE) && (TCL_RELEASE_SERIAL < 3)
/*
** Workaround NRE-specific issue in Tcl_EvalObjCmd (SF bug #3399564) by using
** Tcl_EvalObjv instead of invoking the objProc directly.
*/
# define USE_TCL_EVALOBJV (1)
#else
/*
** We should be able to safely use Tcl_GetCommandInfoFromToken, when the need
** arises, to invoke a specific Tcl command "directly" with some arguments.
*/
# define USE_TCL_EVALOBJV (0)
#endif /* (TCL_MAJOR_VERSION > 8) ... */
#endif /* !defined(USE_TCL_EVALOBJV) */
/*
** 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; \
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
21
22
23
24
25
26
27
28
29
30
31
32
33
34
|
#include "config.h"
#ifdef FOSSIL_ENABLE_TCL
#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; \
|
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
|
Th_Interp *interp,
void *ctx,
int argc,
const char **argv,
int *argl
){
Tcl_Interp *tclInterp;
#if !defined(USE_TCL_EVALOBJV) || !USE_TCL_EVALOBJV
Tcl_Command command;
Tcl_CmdInfo cmdInfo;
#endif /* !defined(USE_TCL_EVALOBJV) || !USE_TCL_EVALOBJV */
int rc = TH_OK;
int nResult;
const char *zResult;
#if !defined(USE_TCL_EVALOBJV) || !USE_TCL_EVALOBJV
Tcl_Obj *objPtr;
#endif /* !defined(USE_TCL_EVALOBJV) || !USE_TCL_EVALOBJV */
USE_ARGV_TO_OBJV();
if( createTclInterp(interp, ctx)!=TH_OK ){
return TH_ERROR;
}
if( argc<2 ){
return Th_WrongNumArgs(interp, "tclInvoke command ?arg ...?");
}
tclInterp = GET_CTX_TCL_INTERP(ctx);
if( !tclInterp || Tcl_InterpDeleted(tclInterp) ){
Th_ErrorMessage(interp, "invalid Tcl interpreter", (const char *)"", 0);
return TH_ERROR;
}
rc = notifyPreOrPostEval(0, interp, ctx, argc, argv, argl, rc);
if( rc!=TH_OK ){
return rc;
}
Tcl_Preserve((ClientData)tclInterp);
#if !defined(USE_TCL_EVALOBJV) || !USE_TCL_EVALOBJV
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;
}
if( !cmdInfo.objProc ){
Th_ErrorMessage(interp, "cannot invoke Tcl command:", argv[1], argl[1]);
Tcl_DecrRefCount(objPtr);
Tcl_Release((ClientData)tclInterp);
return TH_ERROR;
}
Tcl_DecrRefCount(objPtr);
#endif /* !defined(USE_TCL_EVALOBJV) || !USE_TCL_EVALOBJV */
COPY_ARGV_TO_OBJV();
#if defined(USE_TCL_EVALOBJV) && USE_TCL_EVALOBJV
rc = Tcl_EvalObjv(tclInterp, objc, objv, 0);
#else
Tcl_ResetResult(tclInterp);
rc = cmdInfo.objProc(cmdInfo.objClientData, tclInterp, objc, objv);
#endif /* defined(USE_TCL_EVALOBJV) && USE_TCL_EVALOBJV */
FREE_ARGV_TO_OBJV();
zResult = getTclResult(tclInterp, &nResult);
Th_SetResult(interp, zResult, nResult);
Tcl_Release((ClientData)tclInterp);
rc = notifyPreOrPostEval(1, interp, ctx, argc, argv, argl, rc);
return rc;
}
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
|
Th_Interp *interp,
void *ctx,
int argc,
const char **argv,
int *argl
){
Tcl_Interp *tclInterp;
int rc = TH_OK;
int nResult;
const char *zResult;
USE_ARGV_TO_OBJV();
if( createTclInterp(interp, ctx)!=TH_OK ){
return TH_ERROR;
}
if( argc<2 ){
return Th_WrongNumArgs(interp, "tclInvoke command ?arg ...?");
}
tclInterp = GET_CTX_TCL_INTERP(ctx);
if( !tclInterp || Tcl_InterpDeleted(tclInterp) ){
Th_ErrorMessage(interp, "invalid Tcl interpreter", (const char *)"", 0);
return TH_ERROR;
}
rc = notifyPreOrPostEval(0, interp, ctx, argc, argv, argl, rc);
if( rc!=TH_OK ){
return rc;
}
Tcl_Preserve((ClientData)tclInterp);
COPY_ARGV_TO_OBJV();
rc = Tcl_EvalObjv(tclInterp, objc, objv, 0);
FREE_ARGV_TO_OBJV();
zResult = getTclResult(tclInterp, &nResult);
Th_SetResult(interp, zResult, nResult);
Tcl_Release((ClientData)tclInterp);
rc = notifyPreOrPostEval(1, interp, ctx, argc, argv, argl, rc);
return rc;
}
|