Fossil

Check-in [4aba7584]
Login

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

Overview
Comment:Formally translate TH1 to Tcl return codes and vice-versa, where necessary, in the Tcl integration subsystem.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: 4aba7584f7568b817ce33703808972ef15b10e35
User & Date: mistachkin 2015-04-05 00:24:17
Context
2015-04-05
04:28
Initial work on documenting all the Fossil specific TH1 commands. check-in: 1e5548ae user: mistachkin tags: trunk
00:24
Formally translate TH1 to Tcl return codes and vice-versa, where necessary, in the Tcl integration subsystem. check-in: 4aba7584 user: mistachkin tags: trunk
00:23
Add Tcl integration TH1 commands to the docs. check-in: 7cba3078 user: mistachkin tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to src/th_tcl.c.

248
249
250
251
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
...
348
349
350
351
352
353
354
355
356
357


358
359
360
361
362
363
364
...
398
399
400
401
402
403
404
405

406
407
408
409
410
411
412


413
414
415
416
417
418
419
...
459
460
461
462
463
464
465
466

467
468
469
470
471
472
473


474
475
476
477
478
479
480
...
531
532
533
534
535
536
537
538

539
540
541
542
543
544
545

546
547
548
549
550
551
552
...
564
565
566
567
568
569
570
571
572
573
574
575
576
577

578
579
580
581
582
583
584
...
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
/*
** Creates and initializes a Tcl interpreter for use with the specified TH1
** interpreter.  Stores the created Tcl interpreter in the Tcl context supplied
** by the caller.  This must be declared here because quite a few functions in
** this file need to use it before it can be defined.
*/
static int createTclInterp(Th_Interp *interp, void *pContext);



































/*
** Returns a name for a Tcl return code.
*/
static const char *getTclReturnCodeName(
  int rc,
  int nullIfOk
){
  static char zRc[32];

  switch( rc ){
    case TCL_OK:       return nullIfOk ? 0 : "TCL_OK";
    case TCL_ERROR:    return "TCL_ERROR";
    case TCL_BREAK:    return "TCL_BREAK";
    case TCL_RETURN:   return "TCL_RETURN";

    case TCL_CONTINUE: return "TCL_CONTINUE";
    default: {
      sqlite3_snprintf(sizeof(zRc), zRc, "Tcl return code %d", rc);
    }
  }
  return zRc;
}
................................................................................
        tclContext->pPostContext : tclContext->pPreContext,
        interp, ctx, argc, argv, argl, rc);
  }
  return rc;
}

/*
** Syntax:
**
**   tclEval arg ?arg ...?


*/
static int tclEval_command(
  Th_Interp *interp,
  void *ctx,
  int argc,
  const char **argv,
  int *argl
................................................................................
    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);
  rc = notifyPreOrPostEval(1, interp, ctx, argc, argv, argl, rc);

  return rc;
}

/*
** Syntax:
**
**   tclExpr arg ?arg ...?


*/
static int tclExpr_command(
  Th_Interp *interp,
  void *ctx,
  int argc,
  const char **argv,
  int *argl
................................................................................
    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);
  rc = notifyPreOrPostEval(1, interp, ctx, argc, argv, argl, rc);

  return rc;
}

/*
** Syntax:
**
**   tclInvoke command ?arg ...?


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

/*
** Syntax:
**
**   th1Eval arg

*/
static int Th1EvalObjCmd(
  ClientData clientData,
  Tcl_Interp *interp,
  int objc,
  Tcl_Obj *const objv[]
){
................................................................................
    Tcl_AppendResult(interp, "invalid TH1 interpreter", NULL);
    return TCL_ERROR;
  }
  arg = Tcl_GetStringFromObj(objv[1], &nArg);
  rc = Th_Eval(th1Interp, 0, arg, nArg);
  arg = Th_GetResult(th1Interp, &nArg);
  Tcl_SetObjResult(interp, Tcl_NewStringObj(arg, nArg));
  return rc;
}

/*
** Syntax:
**
**   th1Expr arg

*/
static int Th1ExprObjCmd(
  ClientData clientData,
  Tcl_Interp *interp,
  int objc,
  Tcl_Obj *const objv[]
){
................................................................................
    Tcl_AppendResult(interp, "invalid TH1 interpreter", NULL);
    return TCL_ERROR;
  }
  arg = Tcl_GetStringFromObj(objv[1], &nArg);
  rc = Th_Expr(th1Interp, arg, nArg);
  arg = Th_GetResult(th1Interp, &nArg);
  Tcl_SetObjResult(interp, Tcl_NewStringObj(arg, nArg));
  return rc;
}

/*
** Array of Tcl integration commands.  Used when adding or removing the Tcl
** integration commands from TH1.
*/
static struct _Command {







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













<

>







 







|

|
>
>







 







|
>




|

|
>
>







 







|
>




|

|
>
>







 







|
>




|

|
>







 







|



|

|
>







 







|







248
249
250
251
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
297
298
299
300
301

302
303
304
305
306
307
308
309
310
...
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
...
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
...
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
...
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
...
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
...
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
/*
** Creates and initializes a Tcl interpreter for use with the specified TH1
** interpreter.  Stores the created Tcl interpreter in the Tcl context supplied
** by the caller.  This must be declared here because quite a few functions in
** this file need to use it before it can be defined.
*/
static int createTclInterp(Th_Interp *interp, void *pContext);

/*
** Returns the TH1 return code corresponding to the specified Tcl
** return code.
*/
static int getTh1ReturnCode(
  int rc /* The Tcl return code value to convert. */
){
  switch( rc ){
    case /*0*/ TCL_OK:       return /*0*/ TH_OK;
    case /*1*/ TCL_ERROR:    return /*1*/ TH_ERROR;
    case /*2*/ TCL_RETURN:   return /*3*/ TH_RETURN;
    case /*3*/ TCL_BREAK:    return /*2*/ TH_BREAK;
    case /*4*/ TCL_CONTINUE: return /*4*/ TH_CONTINUE;
    default /*?*/:           return /*?*/ rc;
  }
}

/*
** Returns the Tcl return code corresponding to the specified TH1
** return code.
*/
static int getTclReturnCode(
  int rc /* The TH1 return code value to convert. */
){
  switch( rc ){
    case /*0*/ TH_OK:       return /*0*/ TCL_OK;
    case /*1*/ TH_ERROR:    return /*1*/ TCL_ERROR;
    case /*2*/ TH_BREAK:    return /*3*/ TCL_BREAK;
    case /*3*/ TH_RETURN:   return /*2*/ TCL_RETURN;
    case /*4*/ TH_CONTINUE: return /*4*/ TCL_CONTINUE;
    default /*?*/:          return /*?*/ rc;
  }
}

/*
** Returns a name for a Tcl return code.
*/
static const char *getTclReturnCodeName(
  int rc,
  int nullIfOk
){
  static char zRc[32];

  switch( rc ){
    case TCL_OK:       return nullIfOk ? 0 : "TCL_OK";
    case TCL_ERROR:    return "TCL_ERROR";

    case TCL_RETURN:   return "TCL_RETURN";
    case TCL_BREAK:    return "TCL_BREAK";
    case TCL_CONTINUE: return "TCL_CONTINUE";
    default: {
      sqlite3_snprintf(sizeof(zRc), zRc, "Tcl return code %d", rc);
    }
  }
  return zRc;
}
................................................................................
        tclContext->pPostContext : tclContext->pPreContext,
        interp, ctx, argc, argv, argl, rc);
  }
  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
................................................................................
    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);
  rc = notifyPreOrPostEval(1, interp, ctx, argc, argv, argl,
                           getTh1ReturnCode(rc));
  return rc;
}

/*
** 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
................................................................................
    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);
  rc = notifyPreOrPostEval(1, interp, ctx, argc, argv, argl,
                           getTh1ReturnCode(rc));
  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
................................................................................
    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,
                           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.
*/
static int Th1EvalObjCmd(
  ClientData clientData,
  Tcl_Interp *interp,
  int objc,
  Tcl_Obj *const objv[]
){
................................................................................
    Tcl_AppendResult(interp, "invalid TH1 interpreter", NULL);
    return TCL_ERROR;
  }
  arg = Tcl_GetStringFromObj(objv[1], &nArg);
  rc = Th_Eval(th1Interp, 0, arg, nArg);
  arg = Th_GetResult(th1Interp, &nArg);
  Tcl_SetObjResult(interp, Tcl_NewStringObj(arg, nArg));
  return getTclReturnCode(rc);
}

/*
** Tcl command: th1Expr arg
**
** Evaluates the TH1 expression and returns its result verbatim.  If a TH1
** script error is generated, it will be transformed into a Tcl script error.
*/
static int Th1ExprObjCmd(
  ClientData clientData,
  Tcl_Interp *interp,
  int objc,
  Tcl_Obj *const objv[]
){
................................................................................
    Tcl_AppendResult(interp, "invalid TH1 interpreter", NULL);
    return TCL_ERROR;
  }
  arg = Tcl_GetStringFromObj(objv[1], &nArg);
  rc = Th_Expr(th1Interp, arg, nArg);
  arg = Th_GetResult(th1Interp, &nArg);
  Tcl_SetObjResult(interp, Tcl_NewStringObj(arg, nArg));
  return getTclReturnCode(rc);
}

/*
** Array of Tcl integration commands.  Used when adding or removing the Tcl
** integration commands from TH1.
*/
static struct _Command {