Fossil

Check-in [501f35e50a]
Login
☰Home Timeline Docs Forum Download

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

Overview
Comment:Add 'tclIsSafe' and 'tclMakeSafe' commands to the Tcl integration subsystem.
Downloads: Tarball | ZIP archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: 501f35e50a8bdc0e36188beb560f4d6c9348bb0a
User & Date: mistachkin 2015-07-11 23:13:28.317
Context
2015-07-14
00:38
Make the "fossil clean" command undoable. ... (check-in: 1bf792eeeb user: drh tags: trunk)
2015-07-11
23:13
Add 'tclIsSafe' and 'tclMakeSafe' commands to the Tcl integration subsystem. ... (check-in: 501f35e50a user: mistachkin tags: trunk)
22:28
Coding style changes to fossil_utf8_to_console(). ... (check-in: 484a39a784 user: mistachkin tags: trunk)
Changes
Unified Diff Ignore Whitespace Patch
Changes to src/th_tcl.c.
︙︙
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.
*/
static int tclEval_command(
  Th_Interp *interp,
  void *ctx,
  int argc,
  const char **argv,
  int *argl








|
|








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.  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

}

/*
** 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.

*/
static int tclExpr_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
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.
** 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

  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.
*/
static int tclInvoke_command(
  Th_Interp *interp,
  void *ctx,
  int argc,
  const char **argv,
  int *argl








|
|








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.  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

  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;
}



























































































/*
** 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.
*/








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








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

** integration commands from TH1.
*/
static struct _Command {
  const char *zName;
  Th_CommandProc xProc;
  void *pContext;
} aCommand[] = {


  {"tclEval",   tclEval_command,   0},
  {"tclExpr",   tclExpr_command,   0},
  {"tclInvoke", tclInvoke_command, 0},
  {0, 0, 0}
};

/*
** Called if the Tcl interpreter is deleted.  Removes the Tcl integration
** commands from the TH1 interpreter.
*/








>
>
|
|
|








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},
  {"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.
*/
︙︙
Changes to test/th1-tcl.test.
︙︙
121
122
123
124
125
126
127












































fossil test-th-render --open-config \
    [file nativename [file join $dir th1-tcl9.txt]]

test th1-tcl-9 {[string trim $RESULT] eq [list [file tail $fossilexe] 3 \
[list test-th-render --open-config [file nativename [file join $dir \
th1-tcl9.txt]]]]}


















































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

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


fossil test-th-render --open-config \
    [file nativename [file join $dir th1-tcl9.txt]]

test th1-tcl-9 {[string trim $RESULT] eq [list [file tail $fossilexe] 3 \
[list test-th-render --open-config [file nativename [file join $dir \
th1-tcl9.txt]]]]}

###############################################################################

fossil test-th-eval "tclMakeSafe a"
test th1-tcl-10 {[normalize_result] eq \
{TH_ERROR: wrong # args: should be "tclMakeSafe"}}

###############################################################################

fossil test-th-eval "list \[tclIsSafe\] \[tclMakeSafe\] \[tclIsSafe\]"
test th1-tcl-11 {[normalize_result] eq {0 {} 1}}

###############################################################################

fossil test-th-eval "tclMakeSafe; tclMakeSafe"
test th1-tcl-12 {[normalize_result] eq \
{TH_ERROR: Tcl interpreter is already 'safe'}}

###############################################################################

fossil test-th-eval "tclEval pwd; tclMakeSafe; tclEval pwd"
test th1-tcl-13 {[normalize_result] eq {TH_ERROR: invalid command name "pwd"}}

###############################################################################

fossil test-th-eval "tclMakeSafe; tclExpr {0 + \[string length \[pwd\]\]}"
test th1-tcl-14 {[normalize_result] eq {TH_ERROR: invalid command name "pwd"}}

###############################################################################

fossil test-th-eval "tclInvoke pwd; tclMakeSafe; tclInvoke pwd"
test th1-tcl-15 {[normalize_result] eq {TH_ERROR: Tcl command not found: pwd}}

###############################################################################

fossil test-th-eval "tclMakeSafe; tclEval set x 2"
test th1-tcl-16 {[normalize_result] eq {2}}

###############################################################################

fossil test-th-eval "tclMakeSafe; tclEval set x 2; tclEval info vars x"
test th1-tcl-17 {[normalize_result] eq {x}}
Changes to www/th1.md.
︙︙
152
153
154
155
156
157
158


159
160
161
162
163
164
165

  *  setParameter
  *  setting
  *  styleHeader
  *  styleFooter
  *  tclEval
  *  tclExpr
  *  tclInvoke


  *  tclReady
  *  trace
  *  stime
  *  utime
  *  wiki

Each of the commands above is documented by a block comment above their








>
>








152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167

  *  setParameter
  *  setting
  *  styleHeader
  *  styleFooter
  *  tclEval
  *  tclExpr
  *  tclInvoke
  *  tclIsSafe
  *  tclMakeSafe
  *  tclReady
  *  trace
  *  stime
  *  utime
  *  wiki

Each of the commands above is documented by a block comment above their
︙︙
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
508

-----------------------------------------

**This command requires the Tcl integration feature.**

  *  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.

<a name="tclExpr"></a>TH1 tclExpr Command
-----------------------------------------

**This command requires the Tcl integration feature.**

  *  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.


<a name="tclInvoke"></a>TH1 tclInvoke Command
---------------------------------------------

**This command requires the Tcl integration feature.**

  *  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.























<a name="tclReady"></a>TH1 tclReady Command
-------------------------------------------

  *  tclReady

Returns true if the binary has the Tcl integration feature enabled and it








|
|









|
|
>









|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>








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
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533

-----------------------------------------

**This command requires the Tcl integration feature.**

  *  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.  The
Tcl interpreter will be created automatically if it has not been already.

<a name="tclExpr"></a>TH1 tclExpr Command
-----------------------------------------

**This command requires the Tcl integration feature.**

  *  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.  The Tcl interpreter will be created automatically if it has not
been already.

<a name="tclInvoke"></a>TH1 tclInvoke Command
---------------------------------------------

**This command requires the Tcl integration feature.**

  *  tclInvoke command ?arg ...?

Invokes the Tcl command using the supplied arguments.  No additional
substitutions are performed on the arguments.  The Tcl interpreter
will be created automatically if it has not been already.

<a name="tclIsSafe"></a>TH1 tclIsSafe Command
---------------------------------------------

**This command requires the Tcl integration feature.**

  *  tclIsSafe

Returns non-zero if the Tcl interpreter is "safe".  The Tcl interpreter
will be created automatically if it has not been already.

<a name="tclMakeSafe"></a>TH1 tclMakeSafe Command
---------------------------------------------

**This command requires the Tcl integration feature.**

  *  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.  The Tcl
interpreter will be created automatically if it has not been already.

<a name="tclReady"></a>TH1 tclReady Command
-------------------------------------------

  *  tclReady

Returns true if the binary has the Tcl integration feature enabled and it
︙︙
This page was generated in about 0.02s by Fossil 2.26 [1205ec86cb] 2025-04-30 16:57:32