Changes On Branch support-tcl84-stubs
Not logged in

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

Changes In Branch support-tcl84-stubs Excluding Merge-Ins

This is equivalent to a diff from da96f916cb to 2234fabe76

2013-09-27
14:41
The various "diff --tk" commands now take an optional, undocumented option "--script FILENAME" that causes the Tk script to be written into FILENAME rather than to be run. One use for this is to get a copy of the diff script in a form were it can be easily edited and enhanced before being moved back into Fossil. check-in: 326a736493 user: drh tags: tkdiff-enhancements
2013-09-25
23:56
Add formal unloading support to the Tcl integration subsystem. This is necessary to prevent a deadlock while exiting the process when Tcl is loaded. Add runtime detection of the ability to directly invoke an objProc for a Tcl command. Support USE_TCL_STUBS define in the version information. check-in: 6b58c67ed8 user: mistachkin tags: trunk
08:29
FOSSIL_ENABLE_TCL_PRIVATE_STUBS only makes sense when USE_TCL_STUBS is defined as well. Use that consistantly in the code. Easier testing whether Tcl integration works fine, just by "fossil version -v". check-in: 0038f4c999 user: jan.nijtmans tags: pending-review
2013-09-24
16:11
merged in trunk Closed-Leaf check-in: 4fb3675a1a user: stephan tags: usage-command
2013-09-23
12:09
Loading Tcl 8.4 only works when USE_TCL_EVALOBJV=1. Reason: the function Tcl_GetCommandFromObj is introduced in Tcl 8.5 (TIP #139). Actually, the source code history for Tcl indicates that this is not correct. Both Tcl_GetCommandFromObj and Tcl_GetCommandInfoFromToken are present for Tcl 8.4. The Tcl_GetCommandInfoFromToken function was added in... Closed-Leaf check-in: 2234fabe76 user: jan.nijtmans tags: support-tcl84-stubs
10:17
Prevent a crash in fossil during exit, when a mingw-compiled (with dw2) Tcl version is still loaded. This is clearly a dw2 bug (see: http://comments.gmane.org/gmane.comp.gnu.mingw.user/41724), but the suggested workaround works and is managable. check-in: da96f916cb user: jan.nijtmans tags: trunk
2013-09-19
18:36
Per feedback, further improve the Tcl shared library error message. check-in: aad3ef3288 user: mistachkin tags: trunk

Changes to src/main.c.

821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
    fossil_print("Schema version %s\n", AUX_SCHEMA);
    fossil_print("zlib %s, loaded %s\n", ZLIB_VERSION, zlibVersion());
#if defined(FOSSIL_ENABLE_SSL)
    fossil_print("SSL (%s)\n", OPENSSL_VERSION_TEXT);
#endif
#if defined(FOSSIL_ENABLE_TCL)
    Th_FossilInit(TH_INIT_DEFAULT | TH_INIT_FORCE_TCL);
    rc = Th_Eval(g.interp, 0, "tclEval {info patchlevel}", -1);
    zRc = Th_ReturnCodeName(rc, 0);
    fossil_print("TCL (Tcl %s, loaded %s: %s)\n",
      TCL_PATCH_LEVEL, zRc, Th_GetResult(g.interp, 0)
    );
#endif
#if defined(FOSSIL_ENABLE_TCL_STUBS)
    fossil_print("TCL_STUBS\n");







|







821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
    fossil_print("Schema version %s\n", AUX_SCHEMA);
    fossil_print("zlib %s, loaded %s\n", ZLIB_VERSION, zlibVersion());
#if defined(FOSSIL_ENABLE_SSL)
    fossil_print("SSL (%s)\n", OPENSSL_VERSION_TEXT);
#endif
#if defined(FOSSIL_ENABLE_TCL)
    Th_FossilInit(TH_INIT_DEFAULT | TH_INIT_FORCE_TCL);
    rc = Th_Eval(g.interp, 0, "tclInvoke info patchlevel", -1);
    zRc = Th_ReturnCodeName(rc, 0);
    fossil_print("TCL (Tcl %s, loaded %s: %s)\n",
      TCL_PATCH_LEVEL, zRc, Th_GetResult(g.interp, 0)
    );
#endif
#if defined(FOSSIL_ENABLE_TCL_STUBS)
    fossil_print("TCL_STUBS\n");

Changes to src/th_tcl.c.

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

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







|






|


|

|



|
>







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

/*
** 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.4, 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.4, 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.4, 8.6b1 or b2.
 */
#if (TCL_MAJOR_VERSION == 8) && (TCL_MINOR_VERSION < 5) || (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. In addition, Tcl 8.4
** doesn't have the function Tcl_GetCommandFromObj (see TIP #139)
 */
#  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.
 */
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;
}







|


|



|

|


















|
















|

|




|







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
508
  Th_Interp *interp,
  void *ctx,
  int argc,
  const char **argv,
  int *argl
){
  Tcl_Interp *tclInterp;
#if !USE_TCL_EVALOBJV
  Tcl_Command command;
  Tcl_CmdInfo cmdInfo;
#endif /* !USE_TCL_EVALOBJV */
  int rc = TH_OK;
  int nResult;
  const char *zResult;
#if !USE_TCL_EVALOBJV
  Tcl_Obj *objPtr;
#endif /* !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 !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 /* !USE_TCL_EVALOBJV */
  COPY_ARGV_TO_OBJV();
#if USE_TCL_EVALOBJV
  rc = Tcl_EvalObjv(tclInterp, objc, objv, 0);
#else
  Tcl_ResetResult(tclInterp);
  rc = cmdInfo.objProc(cmdInfo.objClientData, tclInterp, objc, objv);
#endif /* 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;
}
668
669
670
671
672
673
674
675
676
677

678



679
680
681
682
683
684
685
      }
      *pLibrary = library;
      *pxFindExecutable = xFindExecutable;
      *pxCreateInterp = xCreateInterp;
      *pxDeleteInterp = xDeleteInterp;
      return TH_OK;
    }
  } while( --fileName[TCL_MINOR_OFFSET]>'3' ); /* Tcl 8.4+ */
  fileName[TCL_MINOR_OFFSET] = 'x';
  Th_ErrorMessage(interp,

      "could not load any supported Tcl 8.6, 8.5, or 8.4 shared library \"",



      fileName, -1);
  return TH_ERROR;
#else
  *pLibrary = 0;
  *pxFindExecutable = Tcl_FindExecutable;
  *pxCreateInterp = Tcl_CreateInterp;
  *pxDeleteInterp = Tcl_DeleteInterp;







|


>

>
>
>







669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
      }
      *pLibrary = library;
      *pxFindExecutable = xFindExecutable;
      *pxCreateInterp = xCreateInterp;
      *pxDeleteInterp = xDeleteInterp;
      return TH_OK;
    }
  } while( --fileName[TCL_MINOR_OFFSET]>(USE_TCL_EVALOBJV?'4':'3') ); /* Tcl 8.5+ or 4*/
  fileName[TCL_MINOR_OFFSET] = 'x';
  Th_ErrorMessage(interp,
#if USE_TCL_EVALOBJV
      "could not load any supported Tcl 8.6, 8.5, or 8.4 shared library \"",
#else
      "could not load any supported Tcl 8.6 or 8.5 shared library \"",
#endif
      fileName, -1);
  return TH_ERROR;
#else
  *pLibrary = 0;
  *pxFindExecutable = Tcl_FindExecutable;
  *pxCreateInterp = Tcl_CreateInterp;
  *pxDeleteInterp = Tcl_DeleteInterp;