437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
|
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
|
-
-
+
+
|
return rc;
}
/*
** TH1 command: tclEval arg ?arg ...?
**
** Evaluates the Tcl script and returns its result verbatim. If a Tcl script
** error is generated, it will be transformed into a TH1 script error. A Tcl
** interpreter will be created automatically if it has not been already.
** error is generated, it will be transformed into a TH1 script error. The
** Tcl interpreter will be created automatically if it has not been already.
*/
static int tclEval_command(
Th_Interp *interp,
void *ctx,
int argc,
const char **argv,
int *argl
|
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
|
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
|
-
+
+
|
}
/*
** TH1 command: tclExpr arg ?arg ...?
**
** Evaluates the Tcl expression and returns its result verbatim. If a Tcl
** script error is generated, it will be transformed into a TH1 script error.
** A Tcl interpreter will be created automatically if it has not been already.
** The Tcl interpreter will be created automatically if it has not been
** already.
*/
static int tclExpr_command(
Th_Interp *interp,
void *ctx,
int argc,
const char **argv,
int *argl
|
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
|
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
|
-
-
+
+
|
return rc;
}
/*
** TH1 command: tclInvoke command ?arg ...?
**
** Invokes the Tcl command using the supplied arguments. No additional
** substitutions are performed on the arguments. A Tcl interpreter will
** be created automatically if it has not been already.
** substitutions are performed on the arguments. The Tcl interpreter
** will be created automatically if it has not been already.
*/
static int tclInvoke_command(
Th_Interp *interp,
void *ctx,
int argc,
const char **argv,
int *argl
|
631
632
633
634
635
636
637
638
639
640
641
642
643
644
|
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
|
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
zResult = getTclResult(tclInterp, &nResult);
Th_SetResult(interp, zResult, nResult);
Tcl_Release((ClientData)tclInterp);
rc = notifyPreOrPostEval(1, interp, ctx, argc, argv, argl,
getTh1ReturnCode(rc));
return rc;
}
/*
** TH1 command: tclIsSafe
**
** Returns non-zero if the Tcl interpreter is "safe". The Tcl interpreter
** will be created automatically if it has not been already.
*/
static int tclIsSafe_command(
Th_Interp *interp,
void *ctx,
int argc,
const char **argv,
int *argl
){
Tcl_Interp *tclInterp;
if( createTclInterp(interp, ctx)!=TH_OK ){
return TH_ERROR;
}
if( argc!=1 ){
return Th_WrongNumArgs(interp, "tclIsSafe");
}
tclInterp = GET_CTX_TCL_INTERP(ctx);
if( !tclInterp || Tcl_InterpDeleted(tclInterp) ){
Th_ErrorMessage(interp, "invalid Tcl interpreter", (const char *)"", 0);
return TH_ERROR;
}
Th_SetResultInt(interp, Tcl_IsSafe(tclInterp));
return TH_OK;
}
/*
** TH1 command: tclMakeSafe
**
** Forces the Tcl interpreter into "safe" mode by removing all "unsafe"
** commands and variables. This operation cannot be undone. The Tcl
** interpreter will remain "safe" until the process terminates.
*/
static int tclMakeSafe_command(
Th_Interp *interp,
void *ctx,
int argc,
const char **argv,
int *argl
){
static int registerChans = 1;
Tcl_Interp *tclInterp;
int rc = TH_OK;
if( createTclInterp(interp, ctx)!=TH_OK ){
return TH_ERROR;
}
if( argc!=1 ){
return Th_WrongNumArgs(interp, "tclMakeSafe");
}
tclInterp = GET_CTX_TCL_INTERP(ctx);
if( !tclInterp || Tcl_InterpDeleted(tclInterp) ){
Th_ErrorMessage(interp, "invalid Tcl interpreter", (const char *)"", 0);
return TH_ERROR;
}
if( Tcl_IsSafe(tclInterp) ){
Th_ErrorMessage(interp,
"Tcl interpreter is already 'safe'", (const char *)"", 0);
return TH_ERROR;
}
if( registerChans ){
/*
** HACK: Prevent the call to Tcl_MakeSafe() from actually closing the
** standard channels instead of simply unregistering them from
** the Tcl interpreter. This should only need to be done once
** per thread (process?).
*/
registerChans = 0;
Tcl_RegisterChannel(NULL, Tcl_GetStdChannel(TCL_STDIN));
Tcl_RegisterChannel(NULL, Tcl_GetStdChannel(TCL_STDOUT));
Tcl_RegisterChannel(NULL, Tcl_GetStdChannel(TCL_STDERR));
}
Tcl_Preserve((ClientData)tclInterp);
if( Tcl_MakeSafe(tclInterp)!=TCL_OK ){
int nResult;
const char *zResult = getTclResult(tclInterp, &nResult);
Th_ErrorMessage(interp,
"could not make Tcl interpreter 'safe':", zResult, nResult);
rc = TH_ERROR;
}else{
Th_SetResult(interp, 0, 0);
}
Tcl_Release((ClientData)tclInterp);
return rc;
}
/*
** Tcl command: th1Eval arg
**
** Evaluates the TH1 script and returns its result verbatim. If a TH1 script
** error is generated, it will be transformed into a Tcl script error.
*/
|
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
|
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
|
+
+
-
-
-
+
+
+
|
** integration commands from TH1.
*/
static struct _Command {
const char *zName;
Th_CommandProc xProc;
void *pContext;
} aCommand[] = {
{"tclEval", tclEval_command, 0},
{"tclExpr", tclExpr_command, 0},
{"tclEval", tclEval_command, 0},
{"tclExpr", tclExpr_command, 0},
{"tclInvoke", tclInvoke_command, 0},
{"tclInvoke", tclInvoke_command, 0},
{"tclIsSafe", tclIsSafe_command, 0},
{"tclMakeSafe", tclMakeSafe_command, 0},
{0, 0, 0}
};
/*
** Called if the Tcl interpreter is deleted. Removes the Tcl integration
** commands from the TH1 interpreter.
*/
|