From 85738710b4783ac4ef344a4427f2a9fa8d2fce2e Mon Sep 17 00:00:00 2001
From: Tony Farrell <tony.farrell@mq.edu.au>
Date: Thu, 6 May 2021 10:52:39 +1000
Subject: [PATCH] Fix strncpy use problems
Use of strncpy() in dtclcommmand.c not always dealing with excess
string length correctly. Resolved and now gives error messages if
a user supplied string is too long.
ACMM Version 3.70
---
dmakefile | 2 +-
dtclcommand.c | 1804 +++++++++++++++++++++++++------------------------
2 files changed, 921 insertions(+), 885 deletions(-)
diff --git a/dmakefile b/dmakefile
index ebb4a7b..e9da5e2 100644
--- a/dmakefile
+++ b/dmakefile
@@ -57,7 +57,7 @@
#if HasTcl
#BeginConfig
#DramaSystem /* Indicates we are part of drama itself */
-ACMM_RELEASE=3_69$(ACMMBUILDVER)
+ACMM_RELEASE=3_70$(ACMMBUILDVER)
RELEASE=r$(ACMM_RELEASE)
SYSTEM=dtcl /* System name (for release */
INCLUDES=DramaIncl $(TCLTK_INCL)
diff --git a/dtclcommand.c b/dtclcommand.c
index c065512..e99031f 100644
--- a/dtclcommand.c
+++ b/dtclcommand.c
@@ -385,120 +385,131 @@ DPRIVATE int DtclOptions(
char **arrayVarName, char **varCvtCmd )
{
- int i;
+ int i;
- for (i=first;i<argc;i++)
- {
+ for (i=first;i<argc;i++)
+ {
if (strcmp(argv[i],"-wait") == 0)
- {
+ {
*wait = 1;
*completionHandler = NULL;
- }
+ }
else if (strcmp(argv[i],"-complete") == 0)
- {
+ {
++i;
*completionHandler = (char *)malloc(strlen(argv[i])+1);
strcpy(*completionHandler,argv[i]);
*wait = 0;
- }
+ }
else if (strcmp(argv[i],"-success") == 0)
- {
+ {
++i;
*successHandler = (char *)malloc(strlen(argv[i])+1);
strcpy(*successHandler,argv[i]);
- }
+ }
else if (strcmp(argv[i],"-error") == 0)
- {
+ {
++i;
*errorHandler = (char *)malloc(strlen(argv[i])+1);
strcpy(*errorHandler,argv[i]);
- }
+ }
else if (strcmp(argv[i],"-trigger") == 0)
- {
+ {
++i;
*triggerHandler = (char *)malloc(strlen(argv[i])+1);
strcpy(*triggerHandler,argv[i]);
- }
+ }
else if (strcmp(argv[i],"-info") == 0)
- {
+ {
++i;
*infoHandler = (char *)malloc(strlen(argv[i])+1);
strcpy(*infoHandler,argv[i]);
- }
+ }
else if (strcmp(argv[i],"-node") == 0)
- {
+ {
++i;
+ if (strlen(argv[i]) >= (sizeof(details->Node)-1))
+ {
+ char result[256];
+ sprintf(result,"%s:Option \"-node\", node name \"%s\" too long, %d bytes, we only support %d bytes (DTCL DUI)",
+ argv[0], argv[i], strlen(argv[i]), sizeof(details->Node)-1);
+ Tcl_SetResult(interp,result,TCL_VOLATILE);
+ return TCL_ERROR;
+ }
+
+
+
strncpy(details->Node,argv[i],sizeof(details->Node));
- }
+ }
else if (strcmp(argv[i],"-pathtimeout") == 0)
- {
+ {
++i;
details->GetPathTimeout = atol(argv[i]);
- }
+ }
else if (strcmp(argv[i],"-timeout") == 0)
- {
+ {
++i;
details->Timeout = atol(argv[i]);
- }
+ }
else if (strcmp(argv[i],"-deletearg") == 0)
- {
- *argFlag = DITS_ARG_DELETE;
- }
+ {
+ *argFlag = DITS_ARG_DELETE;
+ }
else if (strcmp(argv[i],"-argfreeid") == 0)
- {
- *argFlag = DITS_ARG_FREEID;
- }
+ {
+ *argFlag = DITS_ARG_FREEID;
+ }
else if (strcmp(argv[i],"-argreadfree") == 0)
- {
- *argFlag = DITS_ARG_READFREE;
- }
+ {
+ *argFlag = DITS_ARG_READFREE;
+ }
else if (strcmp(argv[i],"-noflush") == 0)
- {
+ {
*flush = 0;
- }
+ }
else if ((strcmp(argv[i],"-sendcur") == 0)&&
- (details->MsgType == DITS_MSG_MONITOR))
- {
+ (details->MsgType == DITS_MSG_MONITOR))
+ {
details->SendCur = 1;
- }
+ }
else if ((strcmp(argv[i],"-variable") == 0)&&
- (details->MsgType == DITS_MSG_MONITOR))
- {
+ (details->MsgType == DITS_MSG_MONITOR))
+ {
++i;
*arrayVarName = (char *)malloc(strlen(argv[i])+1);
strcpy(*arrayVarName,argv[i]);
- }
+ }
else if ((strcmp(argv[i],"-varcvtcmd") == 0)&&
- (details->MsgType == DITS_MSG_MONITOR))
- {
+ (details->MsgType == DITS_MSG_MONITOR))
+ {
++i;
*varCvtCmd = (char *)malloc(strlen(argv[i])+1);
strcpy(*varCvtCmd,argv[i]);
- }
+ }
else if ((strcmp(argv[i],"-repmonloss") == 0)&&
- (details->MsgType == DITS_MSG_MONITOR))
- {
+ (details->MsgType == DITS_MSG_MONITOR))
+ {
details->ReportMonLoss = 1;
- }
+ }
else if ((strcmp(argv[i],"-kickarg") == 0)&&
- (details->MsgType ==DITS_MSG_OBEY))
- {
+ (details->MsgType ==DITS_MSG_OBEY))
+ {
++i;
*kickargvar = argv[i];
- }
+ }
else
- {
- char result[256];
- sprintf(result,"%s:Unknown option - \"%s\"",
- argv[0],argv[i]);
- Tcl_SetResult(interp,result,TCL_VOLATILE);
- return TCL_ERROR;
- }
- }
- return TCL_OK;
+ {
+ char result[256];
+ sprintf(result,"%s:Unknown option - \"%s\"",
+ argv[0],argv[i]);
+ Tcl_SetResult(interp,result,TCL_VOLATILE);
+ return TCL_ERROR;
+ }
+ }
+ return TCL_OK;
}
/*
@@ -2834,8 +2845,8 @@ DPRIVATE int DtclTranslate(ClientData clientdata DUNUSED,
*/
if (error == format || error == range || error == decimal_point)
{
- char result[256];
- char theString[100];
+ char result[256];
+ char theString[100];
strncpy (theString,argv[1],sizeof(theString));
theString[sizeof(theString) - 1] = '\0';
if (error == format)
@@ -3884,411 +3895,436 @@ DPRIVATE int DtclParseFile(ClientData clientdata DUNUSED, Tcl_Interp *interp,
18-Aug-2015 - TJF - Replace calls to ErsRep() with ERS_M_NOFMT flag set
by calls to new ErsRepNF(), to avoid compiler
warnings.
+ 06-May-2021 - TJF - String copies not dealing well with node, task or
+ action names which were too log. All now
+ return error messages.
+
*/
DPRIVATE int DtclExecute(ClientData clientdata, Tcl_Interp *interp, int argc,
- char *argv[])
+ char *argv[])
{
- DtclCmdInfoType *CmdInfo = (DtclCmdInfoType *)clientdata;
- StatusType status;
- int wait = 0;
- DuiDetailsType *details;
- char *completionHandler = NULL;
- char *successHandler = NULL;
- char *errorHandler = NULL;
- char *triggerHandler = NULL;
- char *infoHandler = NULL;
- char *kickargvar = NULL;
- char *arrayvar = NULL;
- char *varcvtcmd = NULL;
- int NeedArgs;
- DtclHandlerType *handlers;
- char buffer[200];
- char buff2[20];
- int result;
- int next_arg;
- DitsArgFlagType ArgFlag=DITS_ARG_NODELETE;
- int flush = 1;
- int badArg = 0;
- DitsCtxForceStateType Ucontext;
-
- if (CmdInfo->MsgType == DITS_MSG_SETPARAM)
- NeedArgs = 4;
- else
- NeedArgs = 3;
- if (argc < NeedArgs)
- {
+ DtclCmdInfoType *CmdInfo = (DtclCmdInfoType *)clientdata;
+ StatusType status;
+ int wait = 0;
+ DuiDetailsType *details;
+ char *completionHandler = NULL;
+ char *successHandler = NULL;
+ char *errorHandler = NULL;
+ char *triggerHandler = NULL;
+ char *infoHandler = NULL;
+ char *kickargvar = NULL;
+ char *arrayvar = NULL;
+ char *varcvtcmd = NULL;
+ int NeedArgs;
+ DtclHandlerType *handlers;
+ char buffer[200];
+ char buff2[20];
+ int result;
+ int next_arg;
+ DitsArgFlagType ArgFlag=DITS_ARG_NODELETE;
+ int flush = 1;
+ int badArg = 0;
+ DitsCtxForceStateType Ucontext;
+
+ if (CmdInfo->MsgType == DITS_MSG_SETPARAM)
+ NeedArgs = 4;
+ else
+ NeedArgs = 3;
+ if (argc < NeedArgs)
+ {
char result[256];
sprintf(result,"%s:wrong # args",argv[0]);
Tcl_SetResult(interp,result,TCL_VOLATILE);
return DtclCmdError(interp,0,DTCL__ARGERR);
- }
- status = STATUS__OK;
+ }
+ status = STATUS__OK;
/* Set up the details structure for the command */
- details = (DuiDetailsType *)malloc(sizeof(DuiDetailsType));
- handlers = (DtclHandlerType *)malloc(sizeof(DtclHandlerType));
- DuiDetailsInit(details);
+ details = (DuiDetailsType *)malloc(sizeof(DuiDetailsType));
+ handlers = (DtclHandlerType *)malloc(sizeof(DtclHandlerType));
+ DuiDetailsInit(details);
- details->Logging = CmdInfo->context->Logging;
- details->MsgType = CmdInfo->MsgType;
+ details->Logging = CmdInfo->context->Logging;
+ details->MsgType = CmdInfo->MsgType;
/*
* By default, we tell DUI to copy the argument and delete the copy when
* the action has been started (NOTE - I THINK THIS IS ACTUALLY IGNORED - local ArgFlag is used and
* copied in details->ArgFlag below. Don't know why. TJF, 21/Oct/2008.)
*/
- details->ArgFlag = DITS_ARG_COPY;
- strncpy(details->TaskName,argv[1],sizeof(details->TaskName)-1);
- strncpy(details->Action,argv[2],sizeof(details->Action)-1);
- if (CmdInfo->MsgType == DITS_MSG_GETPARAM)
- {
+ details->ArgFlag = DITS_ARG_COPY;
+/*
+ * Copy taskname and action name, ensuring they are not too long.
+ */
+ if (strlen(argv[1]) > (sizeof(details->TaskName)-1))
+ {
+ char result[256];
+ sprintf(result,"%s:Task name \"%s\" too long, %d bytes, we only support %d bytes (DTCL DUI)",
+ argv[0], argv[1], strlen(argv[1]), sizeof(details->TaskName)-1);
+ Tcl_SetResult(interp,result,TCL_VOLATILE);
+ return TCL_ERROR;
+
+ }
+ strncpy(details->TaskName,argv[1],sizeof(details->TaskName));
+
+ if (strlen(argv[2]) > (sizeof(details->Action)-1))
+ {
+ char result[256];
+ sprintf(result,"%s:Action/Parameter name \"%s\" too long, %d bytes, we only support %d bytes (DTCL DUI)",
+ argv[0], argv[2], strlen(argv[2]), sizeof(details->Action)-1);
+ Tcl_SetResult(interp,result,TCL_VOLATILE);
+ return TCL_ERROR;
+ }
+ strncpy(details->Action,argv[2],sizeof(details->Action));
+ if (CmdInfo->MsgType == DITS_MSG_GETPARAM)
+ {
/*
* We assume a multiple parameter get if the next name does
* not begin with a -, or if the name is too longer to fit in the action
* name spot (indicating we are using a long parameter name format).
*/
- if (((argc > 3)&&(*argv[3] != '-'))||
- (strlen(argv[2]) > DITS_C_NAMELEN-1))
- {
- register int i;
- ArgFlag = DITS_ARG_DELETE;
- details->MsgType = DITS_MSG_MGETPARAM;
- ArgNew(&details->ArgId,&status);
- next_arg = 2;
- for (i = 2; (i < argc)&&(*argv[i] != '-')&&(status == STATUS__OK);
- ++i, ++next_arg)
- {
- char name[30];
- sprintf(name,"Argument%d",i-1);
- ArgPutString(details->ArgId,name,argv[i],&status);
- }
- }
- else /* Single parameter get */
- next_arg = 3;
- }
- else if (CmdInfo->MsgType == DITS_MSG_SETPARAM)
- {
- if ((details->ArgId = atol(argv[3])) == 0)
- badArg = 1;
- next_arg = 4;
- }
- else
- {
- if ((argc >= 4)&&(argv[3][0] != '-'))
- {
- if ((details->ArgId = atol(argv[3])) == 0)
- badArg = 1;
- next_arg = 4;
- }
- else
- next_arg = 3;
- }
+ if (((argc > 3)&&(*argv[3] != '-'))||
+ (strlen(argv[2]) > DITS_C_NAMELEN-1))
+ {
+ register int i;
+ ArgFlag = DITS_ARG_DELETE;
+ details->MsgType = DITS_MSG_MGETPARAM;
+ ArgNew(&details->ArgId,&status);
+ next_arg = 2;
+ for (i = 2; (i < argc)&&(*argv[i] != '-')&&(status == STATUS__OK);
+ ++i, ++next_arg)
+ {
+ char name[30];
+ sprintf(name,"Argument%d",i-1);
+ ArgPutString(details->ArgId,name,argv[i],&status);
+ }
+ }
+ else /* Single parameter get */
+ next_arg = 3;
+ }
+ else if (CmdInfo->MsgType == DITS_MSG_SETPARAM)
+ {
+ if ((details->ArgId = atol(argv[3])) == 0)
+ badArg = 1;
+ next_arg = 4;
+ }
+ else
+ {
+ if ((argc >= 4)&&(argv[3][0] != '-'))
+ {
+ if ((details->ArgId = atol(argv[3])) == 0)
+ badArg = 1;
+ next_arg = 4;
+ }
+ else
+ next_arg = 3;
+ }
/*
* If we have a ArgId, ensure it represents a valid Sds item. This will
* be picked up later but possibly after waiting to get the path, so
* it is better to do it now.
*/
- if (details->ArgId)
- {
- char name[16];
- SdsIdType code;
- long ndims;
- unsigned long dims[7];
- SdsInfo(details->ArgId,name,&code,&ndims,dims,&status);
- if (status != STATUS__OK) badArg = 1;
- }
- if (badArg)
- {
- char result[256];
- free(details);
- free(handlers);
- sprintf(result,"%s:Argument \"%s\" is not a valid SDS id",
- argv[0],argv[3]);
- Tcl_SetResult(interp,result,TCL_VOLATILE);
+ if (details->ArgId)
+ {
+ char name[16];
+ SdsIdType code;
+ long ndims;
+ unsigned long dims[7];
+ SdsInfo(details->ArgId,name,&code,&ndims,dims,&status);
+ if (status != STATUS__OK) badArg = 1;
+ }
+ if (badArg)
+ {
+ char result[256];
+ free(details);
+ free(handlers);
+ sprintf(result,"%s:Argument \"%s\" is not a valid SDS id",
+ argv[0],argv[3]);
+ Tcl_SetResult(interp,result,TCL_VOLATILE);
return DtclCmdError(interp,0,DTCL__ARGERR);
- }
+ }
- details->MessageBytes = CmdInfo->context->MessageBytes;
- details->MaxMessages = CmdInfo->context->MaxMessages;
- details->ReplyBytes = CmdInfo->context->ReplyBytes;
- details->MaxReplies = CmdInfo->context->MaxReplies;
+ details->MessageBytes = CmdInfo->context->MessageBytes;
+ details->MaxMessages = CmdInfo->context->MaxMessages;
+ details->ReplyBytes = CmdInfo->context->ReplyBytes;
+ details->MaxReplies = CmdInfo->context->MaxReplies;
- if (DtclOptions(argc,next_arg,argv,interp,details,
- &wait,&completionHandler,&successHandler,
- &errorHandler,&triggerHandler,&infoHandler,
- &ArgFlag,&flush,&kickargvar,&arrayvar,&varcvtcmd) == TCL_ERROR)
- {
- free(details);
- free(handlers);
- if (successHandler != NULL) free(successHandler);
- if (completionHandler != NULL) free(completionHandler);
- if (errorHandler != NULL) free(errorHandler);
- if (triggerHandler != NULL) free(triggerHandler);
- if (infoHandler != NULL) free(infoHandler);
- if (arrayvar != NULL) free(arrayvar);
- if (varcvtcmd != NULL) free(varcvtcmd);
+ if (DtclOptions(argc,next_arg,argv,interp,details,
+ &wait,&completionHandler,&successHandler,
+ &errorHandler,&triggerHandler,&infoHandler,
+ &ArgFlag,&flush,&kickargvar,&arrayvar,&varcvtcmd) == TCL_ERROR)
+ {
+ free(details);
+ free(handlers);
+ if (successHandler != NULL) free(successHandler);
+ if (completionHandler != NULL) free(completionHandler);
+ if (errorHandler != NULL) free(errorHandler);
+ if (triggerHandler != NULL) free(triggerHandler);
+ if (infoHandler != NULL) free(infoHandler);
+ if (arrayvar != NULL) free(arrayvar);
+ if (varcvtcmd != NULL) free(varcvtcmd);
return DtclCmdError(interp,0,DTCL__ARGERR);
- }
+ }
/*
* If this is a set parameter with a long name, convert to the appropiate
* structure.
*/
- if ((CmdInfo->MsgType == DITS_MSG_SETPARAM)&&
- (strlen(argv[2]) > DITS_C_NAMELEN-1))
- {
- SdsIdType origArg = details->ArgId;
- int external;
- SdsIsExternal(origArg, &external, &status);
- ArgNew(&details->ArgId,&status);
- ArgPutString(details->ArgId,"Argument1",argv[2],&status);
- if ((ArgFlag == DITS_ARG_DELETE)&&(!external))
- {
- /*
- * Argument is not external are we were going to delete
- * it anyway - so we can just insert it into the new
- * structure and free the id.
- */
- SdsInsert(details->ArgId,origArg,&status);
- SdsFreeId(origArg,&status);
- }
- else
- {
- /*
- * Here, we need to copy the structure before we can
- * insert it. So do so and free the id. Set the flag to
- * be delete from this point onwards.
- */
- SdsIdType argCopy;
- SdsCopy(origArg,&argCopy,&status);
- SdsInsert(details->ArgId,argCopy,&status);
+ if ((CmdInfo->MsgType == DITS_MSG_SETPARAM)&&
+ (strlen(argv[2]) > DITS_C_NAMELEN-1))
+ {
+ SdsIdType origArg = details->ArgId;
+ int external;
+ SdsIsExternal(origArg, &external, &status);
+ ArgNew(&details->ArgId,&status);
+ ArgPutString(details->ArgId,"Argument1",argv[2],&status);
+ if ((ArgFlag == DITS_ARG_DELETE)&&(!external))
+ {
+ /*
+ * Argument is not external are we were going to delete
+ * it anyway - so we can just insert it into the new
+ * structure and free the id.
+ */
+ SdsInsert(details->ArgId,origArg,&status);
+ SdsFreeId(origArg,&status);
+ }
+ else
+ {
+ /*
+ * Here, we need to copy the structure before we can
+ * insert it. So do so and free the id. Set the flag to
+ * be delete from this point onwards.
+ */
+ SdsIdType argCopy;
+ SdsCopy(origArg,&argCopy,&status);
+ SdsInsert(details->ArgId,argCopy,&status);
- SdsFreeId(argCopy,&status);
- if (ArgFlag == DITS_ARG_DELETE)
- {
- /* External item - probably not set up correctly */;
- }
- else if (ArgFlag == DITS_ARG_FREEID)
- {
- SdsFreeId(origArg, &status);
- }
- else if (ArgFlag == DITS_ARG_READFREE)
- {
- SdsReadFree(origArg, &status);
- SdsFreeId(origArg, &status);
- }
- ArgFlag = DITS_ARG_DELETE;
- }
- strcpy(details->Action,"_LONG_");
- }
+ SdsFreeId(argCopy,&status);
+ if (ArgFlag == DITS_ARG_DELETE)
+ {
+ /* External item - probably not set up correctly */;
+ }
+ else if (ArgFlag == DITS_ARG_FREEID)
+ {
+ SdsFreeId(origArg, &status);
+ }
+ else if (ArgFlag == DITS_ARG_READFREE)
+ {
+ SdsReadFree(origArg, &status);
+ SdsFreeId(origArg, &status);
+ }
+ ArgFlag = DITS_ARG_DELETE;
+ }
+ strcpy(details->Action,"_LONG_");
+ }
/*
* Can now save the flag.
*/
- details->ArgFlag = ArgFlag;
+ details->ArgFlag = ArgFlag;
- handlers->context = CmdInfo->context;
+ handlers->context = CmdInfo->context;
- if (successHandler != NULL)
- {
+ if (successHandler != NULL)
+ {
details->SuccessHandler = DtclSuccessHandler;
- }
- /* If waiting, then we always invoke the User's error handler directly so */
- /* don't specify DtclErrorHandler in that case. DtclErrorHandlerWait just
- * claims we have handled this. */
- if (errorHandler != NULL)
- {
+ }
+ /* If waiting, then we always invoke the User's error handler directly so */
+ /* don't specify DtclErrorHandler in that case. DtclErrorHandlerWait just
+ * claims we have handled this. */
+ if (errorHandler != NULL)
+ {
details->ErrorHandler = wait ? DtclErrorHandlerWait : DtclErrorHandler;
- }
- if ((triggerHandler != NULL)||(arrayvar != NULL))
- {
+ }
+ if ((triggerHandler != NULL)||(arrayvar != NULL))
+ {
details->TriggerHandler = DtclTriggerHandler;
- }
- if (infoHandler != NULL)
- {
+ }
+ if (infoHandler != NULL)
+ {
details->InfoHandler = DtclInfoHandler;
- }
- if (completionHandler != NULL)
- {
+ }
+ if (completionHandler != NULL)
+ {
details->CompleteHandler = DtclCompleteHandler;
- }
- else if (wait)
- {
+ }
+ else if (wait)
+ {
details->CompleteHandler = DtclCompleteWait;
- }
- else
- {
+ }
+ else
+ {
details->CompleteHandler = DtclComplete;
- }
+ }
- /*
- * If we don't have an explict GetPath timeout, then use the
- * main timeout
- */
- if (details->GetPathTimeout == -1)
- details->GetPathTimeout = details->Timeout;
+ /*
+ * If we don't have an explict GetPath timeout, then use the
+ * main timeout
+ */
+ if (details->GetPathTimeout == -1)
+ details->GetPathTimeout = details->Timeout;
- handlers->completionHandler = completionHandler;
- handlers->successHandler = successHandler;
- handlers->errorHandler = errorHandler;
- handlers->triggerHandler = triggerHandler;
- handlers->infoHandler = infoHandler;
- handlers->arrayVarName = arrayvar;
- handlers->varCvtCmd = varcvtcmd;
- handlers->waiting = wait;
+ handlers->completionHandler = completionHandler;
+ handlers->successHandler = successHandler;
+ handlers->errorHandler = errorHandler;
+ handlers->triggerHandler = triggerHandler;
+ handlers->infoHandler = infoHandler;
+ handlers->arrayVarName = arrayvar;
+ handlers->varCvtCmd = varcvtcmd;
+ handlers->waiting = wait;
- details->UserData = handlers;
+ details->UserData = handlers;
/*
* IF invoked from DTCL_COMMAND, we will be running in the context of an
* action. We must force a switch to UFACE context, otherwise, DuiExecuteCmd
* will fail.
*/
- DitsUfaceCtxForce(&Ucontext,&status);
+ DitsUfaceCtxForce(&Ucontext,&status);
/* Execute the command */
- DuiExecuteCmd(details,&status);
+ DuiExecuteCmd(details,&status);
/*
* Wait if necessary.
*/
- (*CmdInfo->context->WaitLoop)(CmdInfo->context, CmdInfo->context->WaitLoopData,wait,&status);
+ (*CmdInfo->context->WaitLoop)(CmdInfo->context, CmdInfo->context->WaitLoopData,wait,&status);
/*
* Restore context.
*/
- DitsUfaceCtxForceRestore(&Ucontext);
+ DitsUfaceCtxForceRestore(&Ucontext);
- if ((status == STATUS__OK)&&(wait))
- status = handlers->WaitStatus;
+ if ((status == STATUS__OK)&&(wait))
+ status = handlers->WaitStatus;
/*
* Check for errors.
*/
- if (status != STATUS__OK)
- {
- char ResultString[100];
- StatusType ignore = STATUS__OK;
+ if (status != STATUS__OK)
+ {
+ char ResultString[100];
+ StatusType ignore = STATUS__OK;
/*
* If the transactions have been started, we need to forget them
* as we won't now be in a position to handle the reponses when/if
* they occur. The forgotten transactions will become orphans and
* will be handled as such by DRAMA.
*/
- if (details->transid)
- DitsForget(details->transid,&ignore);
- if (details->TimerTransid)
- DitsUfaceTimerCancel(details->TimerTransid,&ignore);
+ if (details->transid)
+ DitsForget(details->transid,&ignore);
+ if (details->TimerTransid)
+ DitsUfaceTimerCancel(details->TimerTransid,&ignore);
/*
* Report the error code
*/
- ErsRep(0,&status,"%s:%s",argv[0],DitsErrorText(status));
+ ErsRep(0,&status,"%s:%s",argv[0],DitsErrorText(status));
/*
* Now create the result string
*/
- switch (CmdInfo->MsgType)
- {
- case DITS_MSG_OBEY:
- ErsSPrintf(sizeof(ResultString),ResultString,
- "%s:Error sending obey %s to task %s",
- argv[0],argv[2],argv[1]);
- break;
- case DITS_MSG_KICK:
- ErsSPrintf(sizeof(ResultString),ResultString,
- "%s:Error sending kick %s to task %s",
- argv[0],argv[2],argv[1]);
- break;
- case DITS_MSG_GETPARAM:
- ErsSPrintf(sizeof(ResultString),ResultString,
- "%s:Error getting parameter %s from task %s",
- argv[0],argv[2],argv[1]);
- break;
- case DITS_MSG_SETPARAM:
- ErsSPrintf(sizeof(ResultString),ResultString,
- "%s:Error setting parameter %s in task %s",
- argv[0],argv[2],argv[1]);
- break;
- case DITS_MSG_CONTROL:
- ErsSPrintf(sizeof(ResultString),ResultString,
- "%s:Error sending control message type %s to task %s",
- argv[0],argv[2],argv[1]);
- break;
- case DITS_MSG_MONITOR:
- default:
- ErsSPrintf(sizeof(ResultString),ResultString,
- "%s:Error sending monitor message on parameter %s to task %s",
- argv[0],argv[2],argv[1]);
- break;
- }
+ switch (CmdInfo->MsgType)
+ {
+ case DITS_MSG_OBEY:
+ ErsSPrintf(sizeof(ResultString),ResultString,
+ "%s:Error sending obey %s to task %s",
+ argv[0],argv[2],argv[1]);
+ break;
+ case DITS_MSG_KICK:
+ ErsSPrintf(sizeof(ResultString),ResultString,
+ "%s:Error sending kick %s to task %s",
+ argv[0],argv[2],argv[1]);
+ break;
+ case DITS_MSG_GETPARAM:
+ ErsSPrintf(sizeof(ResultString),ResultString,
+ "%s:Error getting parameter %s from task %s",
+ argv[0],argv[2],argv[1]);
+ break;
+ case DITS_MSG_SETPARAM:
+ ErsSPrintf(sizeof(ResultString),ResultString,
+ "%s:Error setting parameter %s in task %s",
+ argv[0],argv[2],argv[1]);
+ break;
+ case DITS_MSG_CONTROL:
+ ErsSPrintf(sizeof(ResultString),ResultString,
+ "%s:Error sending control message type %s to task %s",
+ argv[0],argv[2],argv[1]);
+ break;
+ case DITS_MSG_MONITOR:
+ default:
+ ErsSPrintf(sizeof(ResultString),ResultString,
+ "%s:Error sending monitor message on parameter %s to task %s",
+ argv[0],argv[2],argv[1]);
+ break;
+ }
/*
* If we have an error handler, invoke it.
*/
if (handlers->errorHandler != NULL)
- {
- Tcl_DString command;
- MessGetMsg(status,0,sizeof(buffer),buffer);
- sprintf(buff2,"%ld",(long int)status);
+ {
+ Tcl_DString command;
+ MessGetMsg(status,0,sizeof(buffer),buffer);
+ sprintf(buff2,"%ld",(long int)status);
- Tcl_DStringInit(&command);
- Tcl_DStringAppend(&command,handlers->errorHandler,-1);
- Tcl_DStringAppendElement(&command,buffer);
- Tcl_DStringAppendElement(&command,buff2);
- result = DtclGlobalEval(handlers->context->interp,command.string);
+ Tcl_DStringInit(&command);
+ Tcl_DStringAppend(&command,handlers->errorHandler,-1);
+ Tcl_DStringAppendElement(&command,buffer);
+ Tcl_DStringAppendElement(&command,buff2);
+ result = DtclGlobalEval(handlers->context->interp,command.string);
/*
* error handler failed. We Report the ResultString and flush
* Ers (if required) before returning the result of the error handler.
*/
- if (result != TCL_OK)
- {
- char s[200];
- StatusType status = STATUS__OK;
- ErsRepNF(0, &status,ResultString);
- sprintf(s,"\n(DTCL Error Handler for %s \"%s\" to \"%s\")",
- details->MsgTypeString,details->Action,details->TaskName);
- if (flush)
- ErsFlush(&status);
-
- Tcl_AddErrorInfo(interp,s);
- ignore = STATUS__OK;
- DtclComplete(details,&ignore);
- return DtclCmdError(interp,0,DTCL__CMDERR);
- }
- else /* Error handler returned ok */
- {
- ignore = STATUS__OK;
- DtclComplete(details,&ignore);
- return TCL_OK;
- }
- }
+ if (result != TCL_OK)
+ {
+ char s[200];
+ StatusType status = STATUS__OK;
+ ErsRepNF(0, &status,ResultString);
+ sprintf(s,"\n(DTCL Error Handler for %s \"%s\" to \"%s\")",
+ details->MsgTypeString,details->Action,details->TaskName);
+ if (flush)
+ ErsFlush(&status);
+
+ Tcl_AddErrorInfo(interp,s);
+ ignore = STATUS__OK;
+ DtclComplete(details,&ignore);
+ return DtclCmdError(interp,0,DTCL__CMDERR);
+ }
+ else /* Error handler returned ok */
+ {
+ ignore = STATUS__OK;
+ DtclComplete(details,&ignore);
+ return TCL_OK;
+ }
+ }
else
- {
+ {
/*
* No error handler. Flush reported errors if required and return
* the result. We call DtclComplete to tidy up the handlers structure.
*/
- ignore = STATUS__OK;
- DtclComplete(details,&ignore);
- if (flush)
- {
- StatusType ignore = status;
- ErsFlush(&ignore);
- }
- Tcl_SetResult(interp, ResultString, TCL_VOLATILE);
- return DtclCmdError(interp,0,status);
- }
+ ignore = STATUS__OK;
+ DtclComplete(details,&ignore);
+ if (flush)
+ {
+ StatusType ignore = status;
+ ErsFlush(&ignore);
+ }
+ Tcl_SetResult(interp, ResultString, TCL_VOLATILE);
+ return DtclCmdError(interp,0,status);
+ }
}
else
{
- if (wait) /* If we waited, tidy up. */
- DtclComplete(details,&status);
- else if (kickargvar)
- {
+ if (wait) /* If we waited, tidy up. */
+ DtclComplete(details,&status);
+ else if (kickargvar)
+ {
/*
* The user has specified the name of a variable which should
* be set to contain an Sds argument which an be used to kick an
@@ -4301,377 +4337,377 @@ DPRIVATE int DtclExecute(ClientData clientdata, Tcl_Interp *interp, int argc,
* the actual obey. The result will be a reference to an expired
* transaction id.
*/
- SdsIdType arg=0;
- DitsSpawnKickArg(details->transid,&arg,&status);
- if (status != STATUS__OK)
- return DtclCmdError(interp,argv[0],status);
- else
- {
- char buffer[20];
- sprintf(buffer,"%ld",(long int)arg);
- if (Tcl_SetVar(interp,kickargvar,buffer,TCL_LEAVE_ERR_MSG)
- == NULL)
- return DtclCmdError(interp,0,DTCL__CMDERR);
- else
- return TCL_OK;
- }
- }
+ SdsIdType arg=0;
+ DitsSpawnKickArg(details->transid,&arg,&status);
+ if (status != STATUS__OK)
+ return DtclCmdError(interp,argv[0],status);
+ else
+ {
+ char buffer[20];
+ sprintf(buffer,"%ld",(long int)arg);
+ if (Tcl_SetVar(interp,kickargvar,buffer,TCL_LEAVE_ERR_MSG)
+ == NULL)
+ return DtclCmdError(interp,0,DTCL__CMDERR);
+ else
+ return TCL_OK;
+ }
+ }
return TCL_OK;
}
}
-DVOID DtclAddCommands(DtclContextType *context)
+ DVOID DtclAddCommands(DtclContextType *context)
-{
- DtclCmdInfoType *Info;
- StatusType status = STATUS__OK;
+ {
+ DtclCmdInfoType *Info;
+ StatusType status = STATUS__OK;
/*
* Put error facilties requied by this module (really, just all the
* DRAMA facilities not loaded by DitsAppInit(), regardless of if
* we actually use them.
*/
- MessPutFacility(&MessFac_DUL);
- MessPutFacility(&MessFac_DCPP);
- MessPutFacility(&MessFac_GIT);
+ MessPutFacility(&MessFac_DUL);
+ MessPutFacility(&MessFac_DCPP);
+ MessPutFacility(&MessFac_GIT);
/*
* Now ensure all other facilities the user may require are loaded.
*/
- DulLoadFacs(&status);
- if (status != STATUS__OK)
- {
- ErsOut(0,&status,"Error loading error code facilities, %s",
- DitsErrorText(status));
- }
+ DulLoadFacs(&status);
+ if (status != STATUS__OK)
+ {
+ ErsOut(0,&status,"Error loading error code facilities, %s",
+ DitsErrorText(status));
+ }
- Info = (DtclCmdInfoType *)malloc(sizeof(DtclCmdInfoType));
-
- Info->context = context;
- Info->MsgType = DITS_MSG_OBEY;
- Dtcl___CreateCommand(context->interp, "obey", DtclExecute,(ClientData)Info,
- (Tcl_CmdDeleteProc *)NULL);
-
- Info = (DtclCmdInfoType *)malloc(sizeof(DtclCmdInfoType));
- Info->context = context;
- Info->MsgType = DITS_MSG_GETPARAM;
- Dtcl___CreateCommand(context->interp,"pget",DtclExecute,(ClientData)Info,
- (Tcl_CmdDeleteProc *)NULL);
-
- Info = (DtclCmdInfoType *)malloc(sizeof(DtclCmdInfoType));
- Info->context = context;
- Info->MsgType = DITS_MSG_SETPARAM;
- Dtcl___CreateCommand(context->interp,"pset",DtclExecute,(ClientData)Info,
- (Tcl_CmdDeleteProc *)NULL);
-
- Info = (DtclCmdInfoType *)malloc(sizeof(DtclCmdInfoType));
- Info->context = context;
- Info->MsgType = DITS_MSG_KICK;
- Dtcl___CreateCommand(context->interp,"kick",DtclExecute,(ClientData)Info,
- (Tcl_CmdDeleteProc *)NULL);
-
- Info = (DtclCmdInfoType *)malloc(sizeof(DtclCmdInfoType));
- Info->context = context;
- Info->MsgType = DITS_MSG_CONTROL;
- Dtcl___CreateCommand(context->interp,"control",DtclExecute,
- (ClientData)Info,(Tcl_CmdDeleteProc *)NULL);
-
- Info = (DtclCmdInfoType *)malloc(sizeof(DtclCmdInfoType));
- Info->context = context;
- Info->MsgType = DITS_MSG_MONITOR;
- Dtcl___CreateCommand(context->interp,"monitor",DtclExecute,
- (ClientData)Info,(Tcl_CmdDeleteProc *)NULL);
-
- Dtcl___CreateCommand(context->interp,"ErrorHandler",DtclSetErrorHandler,
- (ClientData)context,(Tcl_CmdDeleteProc *)NULL);
- Dtcl___CreateCommand(context->interp,"MessageHandler",DtclSetMessageHandler,
- (ClientData)context,(Tcl_CmdDeleteProc *)NULL);
- Dtcl___CreateCommand(context->interp,"ErsFlush",DtclErsFlush,
- (ClientData)NULL,(Tcl_CmdDeleteProc *)NULL);
- Dtcl___CreateCommand(context->interp,"ErsAnnul",DtclErsAnnul,
- (ClientData)NULL,(Tcl_CmdDeleteProc *)NULL);
- Dtcl___CreateCommand(context->interp,"ErsRep",DtclErsReport,
- (ClientData)NULL,(Tcl_CmdDeleteProc *)NULL);
- Dtcl___CreateCommand(context->interp,"DisconnectHandler",DtclSetDiscon,
- (ClientData)context,(Tcl_CmdDeleteProc *)NULL);
-
- Dtcl___CreateCommand(context->interp,"DitsConnectHandler",DtclSetCon,
- (ClientData)context,(Tcl_CmdDeleteProc *)NULL);
+ Info = (DtclCmdInfoType *)malloc(sizeof(DtclCmdInfoType));
+
+ Info->context = context;
+ Info->MsgType = DITS_MSG_OBEY;
+ Dtcl___CreateCommand(context->interp, "obey", DtclExecute,(ClientData)Info,
+ (Tcl_CmdDeleteProc *)NULL);
+
+ Info = (DtclCmdInfoType *)malloc(sizeof(DtclCmdInfoType));
+ Info->context = context;
+ Info->MsgType = DITS_MSG_GETPARAM;
+ Dtcl___CreateCommand(context->interp,"pget",DtclExecute,(ClientData)Info,
+ (Tcl_CmdDeleteProc *)NULL);
+
+ Info = (DtclCmdInfoType *)malloc(sizeof(DtclCmdInfoType));
+ Info->context = context;
+ Info->MsgType = DITS_MSG_SETPARAM;
+ Dtcl___CreateCommand(context->interp,"pset",DtclExecute,(ClientData)Info,
+ (Tcl_CmdDeleteProc *)NULL);
+
+ Info = (DtclCmdInfoType *)malloc(sizeof(DtclCmdInfoType));
+ Info->context = context;
+ Info->MsgType = DITS_MSG_KICK;
+ Dtcl___CreateCommand(context->interp,"kick",DtclExecute,(ClientData)Info,
+ (Tcl_CmdDeleteProc *)NULL);
+
+ Info = (DtclCmdInfoType *)malloc(sizeof(DtclCmdInfoType));
+ Info->context = context;
+ Info->MsgType = DITS_MSG_CONTROL;
+ Dtcl___CreateCommand(context->interp,"control",DtclExecute,
+ (ClientData)Info,(Tcl_CmdDeleteProc *)NULL);
+
+ Info = (DtclCmdInfoType *)malloc(sizeof(DtclCmdInfoType));
+ Info->context = context;
+ Info->MsgType = DITS_MSG_MONITOR;
+ Dtcl___CreateCommand(context->interp,"monitor",DtclExecute,
+ (ClientData)Info,(Tcl_CmdDeleteProc *)NULL);
+
+ Dtcl___CreateCommand(context->interp,"ErrorHandler",DtclSetErrorHandler,
+ (ClientData)context,(Tcl_CmdDeleteProc *)NULL);
+ Dtcl___CreateCommand(context->interp,"MessageHandler",DtclSetMessageHandler,
+ (ClientData)context,(Tcl_CmdDeleteProc *)NULL);
+ Dtcl___CreateCommand(context->interp,"ErsFlush",DtclErsFlush,
+ (ClientData)NULL,(Tcl_CmdDeleteProc *)NULL);
+ Dtcl___CreateCommand(context->interp,"ErsAnnul",DtclErsAnnul,
+ (ClientData)NULL,(Tcl_CmdDeleteProc *)NULL);
+ Dtcl___CreateCommand(context->interp,"ErsRep",DtclErsReport,
+ (ClientData)NULL,(Tcl_CmdDeleteProc *)NULL);
+ Dtcl___CreateCommand(context->interp,"DisconnectHandler",DtclSetDiscon,
+ (ClientData)context,(Tcl_CmdDeleteProc *)NULL);
+
+ Dtcl___CreateCommand(context->interp,"DitsConnectHandler",DtclSetCon,
+ (ClientData)context,(Tcl_CmdDeleteProc *)NULL);
#ifdef DITS_M_REGISTRAR
- Dtcl___CreateCommand(context->interp,"DitsRegistrationHandler",
- DtclSetRegistration,
- (ClientData)context,(Tcl_CmdDeleteProc *)NULL);
+ Dtcl___CreateCommand(context->interp,"DitsRegistrationHandler",
+ DtclSetRegistration,
+ (ClientData)context,(Tcl_CmdDeleteProc *)NULL);
#endif
- Dtcl___CreateCommand(context->interp,"IsVms",DtclIsVms,
- (ClientData)NULL,(Tcl_CmdDeleteProc *)NULL);
- Dtcl___CreateCommand(context->interp,"IsUnix",DtclIsUnix,
- (ClientData)NULL,(Tcl_CmdDeleteProc *)NULL);
- Dtcl___CreateCommand(context->interp,"IsVxworks",DtclIsVxworks,
- (ClientData)NULL,(Tcl_CmdDeleteProc *)NULL);
+ Dtcl___CreateCommand(context->interp,"IsVms",DtclIsVms,
+ (ClientData)NULL,(Tcl_CmdDeleteProc *)NULL);
+ Dtcl___CreateCommand(context->interp,"IsUnix",DtclIsUnix,
+ (ClientData)NULL,(Tcl_CmdDeleteProc *)NULL);
+ Dtcl___CreateCommand(context->interp,"IsVxworks",DtclIsVxworks,
+ (ClientData)NULL,(Tcl_CmdDeleteProc *)NULL);
- Dtcl___CreateCommand(context->interp,"TranslateName",DtclTrnName,
- (ClientData)NULL,(Tcl_CmdDeleteProc *)NULL);
+ Dtcl___CreateCommand(context->interp,"TranslateName",DtclTrnName,
+ (ClientData)NULL,(Tcl_CmdDeleteProc *)NULL);
- Dtcl___CreateCommand(context->interp,"Translate",DtclTranslate,
- (ClientData)NULL,(Tcl_CmdDeleteProc *)NULL);
+ Dtcl___CreateCommand(context->interp,"Translate",DtclTranslate,
+ (ClientData)NULL,(Tcl_CmdDeleteProc *)NULL);
- Dtcl___CreateCommand(context->interp,"PutFacility",DtclPutFacility,
- (ClientData)NULL,(Tcl_CmdDeleteProc *)NULL);
+ Dtcl___CreateCommand(context->interp,"PutFacility",DtclPutFacility,
+ (ClientData)NULL,(Tcl_CmdDeleteProc *)NULL);
- Dtcl___CreateCommand(context->interp,"DtclFindFile",DtclFindFile,
- (ClientData)context,(Tcl_CmdDeleteProc *)NULL);
+ Dtcl___CreateCommand(context->interp,"DtclFindFile",DtclFindFile,
+ (ClientData)context,(Tcl_CmdDeleteProc *)NULL);
- Dtcl___CreateCommand(context->interp,"DtclParseFile",DtclParseFile,
- (ClientData)context,(Tcl_CmdDeleteProc *)NULL);
+ Dtcl___CreateCommand(context->interp,"DtclParseFile",DtclParseFile,
+ (ClientData)context,(Tcl_CmdDeleteProc *)NULL);
/*
* Put Ers and MsgOut handlers.
*/
- DitsUfacePutErsOut(DtclErsHandler,(DVOIDP)context,&status);
- DitsUfacePutMsgOut(DtclMsgHandler,(DVOIDP)context,&status);
+ DitsUfacePutErsOut(DtclErsHandler,(DVOIDP)context,&status);
+ DitsUfacePutMsgOut(DtclMsgHandler,(DVOIDP)context,&status);
/*
* If running VMS, load VMS specfic commands from the TCL/VMS port
*/
# ifdef VMS
- vms_init(context->interp);
+ vms_init(context->interp);
# endif
-}
+ }
/*
* DRAMA Action handler for action DTCL_COMMAND. It executes a Tcl command
* in the context of this task's Tcl interperter.
*/
-DINTERNAL DVOID DtclCommand(StatusType *status)
+ DINTERNAL DVOID DtclCommand(StatusType *status)
-{
- char cmd[500];
- char string[100];
- DtclContextType *context = (DtclContextType *)DitsGetCode();
+ {
+ char cmd[500];
+ char string[100];
+ DtclContextType *context = (DtclContextType *)DitsGetCode();
/*
* Get the first argument, it is an error not to have one.
*/
- GitArgGetS(DitsGetArgument(),"arg1",1,0,0,0,sizeof(cmd),cmd,0,status);
+ GitArgGetS(DitsGetArgument(),"arg1",1,0,0,0,sizeof(cmd),cmd,0,status);
- if (*status == STATUS__OK)
- {
+ if (*status == STATUS__OK)
+ {
/*
* No concentrante any other arguments, ignoring any error.
*/
- int len;
- register int i;
- ErsPush();
- for (i = 2 ;; ++i)
- {
- GitArgGetS(DitsGetArgument(),"arg",i,0,0,0,
- sizeof(string),string,0,status);
- if (*status != STATUS__OK)
- {
- ErsAnnul(status);
- break;
- }
- else
- {
- len = sizeof(cmd) - (strlen(cmd)+1);
- strncat(cmd," ",len);
- strncat(cmd,string,len-1);
- }
- }
- ErsPop();
+ int len;
+ register int i;
+ ErsPush();
+ for (i = 2 ;; ++i)
+ {
+ GitArgGetS(DitsGetArgument(),"arg",i,0,0,0,
+ sizeof(string),string,0,status);
+ if (*status != STATUS__OK)
+ {
+ ErsAnnul(status);
+ break;
+ }
+ else
+ {
+ len = sizeof(cmd) - (strlen(cmd)+1);
+ strncat(cmd," ",len);
+ strncat(cmd,string,len-1);
+ }
+ }
+ ErsPop();
+ }
+ Dtcl___EvalInAction(context->interp,cmd,status);
}
- Dtcl___EvalInAction(context->interp,cmd,status);
-}
/*+ D i t s P u t A c t S t a t u s
* Command name:
- DitsPutActStatus
+ DitsPutActStatus
* Function:
- Allows an TCL action code to set the DRAMA status.
+ Allows an TCL action code to set the DRAMA status.
* Description:
- The argument is a DRAMA status code which will become
- the status assoicated with the action which invoked this command.
+ The argument is a DRAMA status code which will become
+ the status assoicated with the action which invoked this command.
- This status is used if the action completes without a TCL error.
- If the action completes with a TCL error then the code
- DTCL__TCLCMD will be the action completion status.
+ This status is used if the action completes without a TCL error.
+ If the action completes with a TCL error then the code
+ DTCL__TCLCMD will be the action completion status.
- This command only exists during action invocation and will
- always exist in that case in both the DRAMA and global
- name spaces (assuing namespaces are supported in the TCL version).
+ This command only exists during action invocation and will
+ always exist in that case in both the DRAMA and global
+ name spaces (assuing namespaces are supported in the TCL version).
* Call:
- DitsPutActStatus status
+ DitsPutActStatus status
* Parameters:
- (>) status (int) The DRAMA status code.
+ (>) status (int) The DRAMA status code.
* Language:
- Tcl
+ Tcl
* Support: Tony Farrell, AAO
* See Also: DTCL manual, Dits manual, DitsPutAction(n), DitsPutRequest(n),
- DitsPutArgument(n).
+ DitsPutArgument(n).
*-
* History:
- 10-May-1994 - TJF - Original version
- */
+ 10-May-1994 - TJF - Original version
+*/
-DPRIVATE int Dtcl___PutActStatus(ClientData clientdata,
- Tcl_Interp *interp,
- int argc, char *argv[])
-{
+ DPRIVATE int Dtcl___PutActStatus(ClientData clientdata,
+ Tcl_Interp *interp,
+ int argc, char *argv[])
+ {
/*
* The clientData item points to were we should store the status value
*/
- StatusType *status = (StatusType *)clientdata;
- if (argc != 2)
- {
- char result[256];
- sprintf(result,"%s:Wrong number of arguments", argv[0]);
- Tcl_SetResult(interp,result,TCL_VOLATILE);
- return TCL_ERROR;
+ StatusType *status = (StatusType *)clientdata;
+ if (argc != 2)
+ {
+ char result[256];
+ sprintf(result,"%s:Wrong number of arguments", argv[0]);
+ Tcl_SetResult(interp,result,TCL_VOLATILE);
+ return TCL_ERROR;
+ }
+ *status = (StatusType)atol(argv[1]);
+ return TCL_OK;
}
- *status = (StatusType)atol(argv[1]);
- return TCL_OK;
-}
/*+ D i t s P u t A r g u m e n t
* Command name:
- DitsPutArgument
+ DitsPutArgument
* Function:
- Allows an TCL action code to set the DRAMA completion argument
+ Allows an TCL action code to set the DRAMA completion argument
* Description:
- This command sets the argument associated with the completion
- of a DRAMA action.
+ This command sets the argument associated with the completion
+ of a DRAMA action.
- This argument is used if the action complete and does so
- without a TCL error.
+ This argument is used if the action complete and does so
+ without a TCL error.
- This command only exists during action invocation and will
- always exist in that case in both the DRAMA and global
- name spaces (assuing namespaces are supported in the TCL version).
+ This command only exists during action invocation and will
+ always exist in that case in both the DRAMA and global
+ name spaces (assuing namespaces are supported in the TCL version).
* Call:
- DitsPutArgument id flag
+ DitsPutArgument id flag
* Parameters:
- (>) id (int) The SDS id of the argument.
- (>) flag (string) One of COPY, DELETE or NODELETE, READFREE, FREDID.
- See DitsPutArgument(3) for details.
+ (>) id (int) The SDS id of the argument.
+ (>) flag (string) One of COPY, DELETE or NODELETE, READFREE, FREDID.
+ See DitsPutArgument(3) for details.
* Language:
- Tcl
+ Tcl
* Support: Tony Farrell, AAO
* See Also: DTCL manual, Dits manual, DitsPutAction(n), DitsPutRequest(n),
- DitsPutArgument(n).
+ DitsPutArgument(n).
*-
* History:
- 10-May-1994 - TJF - Original version
- 15-Aug-2006 - TJf - Support READFREE and FREEID options.
- */
+ 10-May-1994 - TJF - Original version
+ 15-Aug-2006 - TJf - Support READFREE and FREEID options.
+*/
/*
* Type used to communicate between Dtcl___PutArgument and
* Dtcl___EvalInAction.
*/
-typedef struct {
- SdsIdType id;
- DitsArgFlagType flag;
-} OutArgType;
+ typedef struct {
+ SdsIdType id;
+ DitsArgFlagType flag;
+ } OutArgType;
-DPRIVATE int Dtcl___PutArgument(ClientData clientdata,
- Tcl_Interp *interp,
- int argc, char *argv[])
-{
+ DPRIVATE int Dtcl___PutArgument(ClientData clientdata,
+ Tcl_Interp *interp,
+ int argc, char *argv[])
+ {
/*
* The clientData item points to were we should store the argument details.
*/
- OutArgType *argDetails = (OutArgType *)clientdata;
- if (argc != 3)
- {
- char result[256];
- sprintf(result,"%s:Wrong number of arguments", argv[0]);
- Tcl_SetResult(interp,result,TCL_VOLATILE);
- return TCL_ERROR;
- }
- argDetails->id = (SdsIdType)atol(argv[1]);
- if (strcasecmp(argv[2],"COPY") == 0)
- argDetails->flag = DITS_ARG_COPY;
- else if (strcasecmp(argv[2],"DELETE") == 0)
- argDetails->flag = DITS_ARG_DELETE;
- else if (strcasecmp(argv[2],"NODELETE") == 0)
- argDetails->flag = DITS_ARG_NODELETE;
- else if (strcasecmp(argv[2],"READFREE") == 0)
- argDetails->flag = DITS_ARG_READFREE;
- else if (strcasecmp(argv[2],"FREEID") == 0)
- argDetails->flag = DITS_ARG_FREEID;
+ OutArgType *argDetails = (OutArgType *)clientdata;
+ if (argc != 3)
+ {
+ char result[256];
+ sprintf(result,"%s:Wrong number of arguments", argv[0]);
+ Tcl_SetResult(interp,result,TCL_VOLATILE);
+ return TCL_ERROR;
+ }
+ argDetails->id = (SdsIdType)atol(argv[1]);
+ if (strcasecmp(argv[2],"COPY") == 0)
+ argDetails->flag = DITS_ARG_COPY;
+ else if (strcasecmp(argv[2],"DELETE") == 0)
+ argDetails->flag = DITS_ARG_DELETE;
+ else if (strcasecmp(argv[2],"NODELETE") == 0)
+ argDetails->flag = DITS_ARG_NODELETE;
+ else if (strcasecmp(argv[2],"READFREE") == 0)
+ argDetails->flag = DITS_ARG_READFREE;
+ else if (strcasecmp(argv[2],"FREEID") == 0)
+ argDetails->flag = DITS_ARG_FREEID;
- else
- {
- char result[256];
- sprintf(result,
- "%s:Invalid flag \"%s\", must be one of COPY, DELETE or NODELETE",
- argv[0],argv[2]);
- Tcl_SetResult(interp,result,TCL_VOLATILE);
- return TCL_ERROR;
+ else
+ {
+ char result[256];
+ sprintf(result,
+ "%s:Invalid flag \"%s\", must be one of COPY, DELETE or NODELETE",
+ argv[0],argv[2]);
+ Tcl_SetResult(interp,result,TCL_VOLATILE);
+ return TCL_ERROR;
+ }
+ return TCL_OK;
}
- return TCL_OK;
-}
/*
* Internal Fuction name:
- Dtcl___EvalInAction
+ Dtcl___EvalInAction
* Description:
- Evaulates a Tcl command assuming it is part of an action routine.
- Any result from the Tcl command is put in the action's output
- argument structure while if an error occurs, Ers text is put in
- the output argument and the error code set to DTCL__TCLCMD;
+ Evaulates a Tcl command assuming it is part of an action routine.
+ Any result from the Tcl command is put in the action's output
+ argument structure while if an error occurs, Ers text is put in
+ the output argument and the error code set to DTCL__TCLCMD;
* History:
- 22-Jul-1996 - TJF - Original version
- 01-Mar-2011 - TJF - Put logging around the command executation.
+ 22-Jul-1996 - TJF - Original version
+ 01-Mar-2011 - TJF - Put logging around the command executation.
- */
+*/
-DINTERNAL DVOID Dtcl___EvalInAction (Tcl_Interp *interp, DCONSTV char *cmd,
- StatusType *status)
-{
- int result;
- SdsIdType id;
- StatusType CmdStatus = STATUS__OK;
- OutArgType OutputArgument = { 0, DITS_ARG_COPY };;
+ DINTERNAL DVOID Dtcl___EvalInAction (Tcl_Interp *interp, DCONSTV char *cmd,
+ StatusType *status)
+ {
+ int result;
+ SdsIdType id;
+ StatusType CmdStatus = STATUS__OK;
+ OutArgType OutputArgument = { 0, DITS_ARG_COPY };;
- if (*status != STATUS__OK) return;
+ if (*status != STATUS__OK) return;
/*
* Add some commands which are only available whilst evaulating an
* action. Note we add both global and namespace versions as
* we can't be sure which mode we are working in.
*/
- Tcl_CreateCommand(interp, "DitsPutActStatus",
- Dtcl___PutActStatus, (ClientData)&CmdStatus, 0);
- Tcl_CreateCommand(interp, "DitsPutArgument",
- Dtcl___PutArgument, (ClientData)&OutputArgument, 0);
+ Tcl_CreateCommand(interp, "DitsPutActStatus",
+ Dtcl___PutActStatus, (ClientData)&CmdStatus, 0);
+ Tcl_CreateCommand(interp, "DitsPutArgument",
+ Dtcl___PutArgument, (ClientData)&OutputArgument, 0);
# if TCL_MAJOR_VERSION >= 8
Tcl_CreateCommand(interp, "drama::DitsPutActStatus",
Dtcl___PutActStatus, (ClientData)&CmdStatus, 0);
@@ -4679,17 +4715,17 @@ DINTERNAL DVOID Dtcl___EvalInAction (Tcl_Interp *interp, DCONSTV char *cmd,
Dtcl___PutArgument, (ClientData)&OutputArgument, 0);
# endif
- DitsLogMsg(DITS_LOG_INST, "Dtcl_EvalInAct", status,
- "Executing Tcl Command \"%s\"", cmd);
+ DitsLogMsg(DITS_LOG_INST, "Dtcl_EvalInAct", status,
+ "Executing Tcl Command \"%s\"", cmd);
/*
* Evalute the command.
*/
- result = DtclGlobalEval(interp,(char *)cmd);
+ result = DtclGlobalEval(interp,(char *)cmd);
- DitsLogMsg(DITS_LOG_INST, "Dtcl_EvalInAct", status,
- "Result = %d", result);
+ DitsLogMsg(DITS_LOG_INST, "Dtcl_EvalInAct", status,
+ "Result = %d", result);
/*
* If the TCL command returned a error then we put the details
@@ -4697,160 +4733,160 @@ DINTERNAL DVOID Dtcl___EvalInAction (Tcl_Interp *interp, DCONSTV char *cmd,
* returned argument (DitsPutArgument()) and there is a result
* string from the TCL command, we return that result string.
*/
- if ((result != TCL_OK)||
- (!OutputArgument.id &&(strlen(Tcl_GetStringResult(interp)) > 0)))
- {
- ArgNew(&id,status);
- ArgPutString(id,"Argument1",Tcl_GetStringResult(interp),status);
- DitsPutArgument(id,DITS_ARG_DELETE,status);
-
- if ((OutputArgument.id)&&(OutputArgument.flag == DITS_ARG_DELETE))
+ if ((result != TCL_OK)||
+ (!OutputArgument.id &&(strlen(Tcl_GetStringResult(interp)) > 0)))
{
+ ArgNew(&id,status);
+ ArgPutString(id,"Argument1",Tcl_GetStringResult(interp),status);
+ DitsPutArgument(id,DITS_ARG_DELETE,status);
+
+ if ((OutputArgument.id)&&(OutputArgument.flag == DITS_ARG_DELETE))
+ {
/*
* If the user supplied an output argument, wanting us to delete
* it, we should do that now, otherwise we will get a leak.
*/
- StatusType ignore = STATUS__OK;
- SdsDelete(OutputArgument.id, &ignore);
- SdsFreeId(OutputArgument.id, &ignore);
+ StatusType ignore = STATUS__OK;
+ SdsDelete(OutputArgument.id, &ignore);
+ SdsFreeId(OutputArgument.id, &ignore);
+ }
}
- }
- else if (OutputArgument.id)
- {
- DitsPutArgument(OutputArgument.id, OutputArgument.flag, status);
- }
- if ((result != TCL_OK)&&(*status == STATUS__OK))
- {
- *status = DTCL__TCLCMD;
- DtclErsRep(interp,1,status);
- }
- else
- *status = CmdStatus;
+ else if (OutputArgument.id)
+ {
+ DitsPutArgument(OutputArgument.id, OutputArgument.flag, status);
+ }
+ if ((result != TCL_OK)&&(*status == STATUS__OK))
+ {
+ *status = DTCL__TCLCMD;
+ DtclErsRep(interp,1,status);
+ }
+ else
+ *status = CmdStatus;
- Tcl_DeleteCommand(interp, "DitsPutActStatus");
- Tcl_DeleteCommand(interp, "DitsPutArgument");
+ Tcl_DeleteCommand(interp, "DitsPutActStatus");
+ Tcl_DeleteCommand(interp, "DitsPutArgument");
# if TCL_MAJOR_VERSION >= 8
Tcl_DeleteCommand(interp, "drama::DitsPutActStatus");
Tcl_DeleteCommand(interp, "drama::DitsPutArgument");
# endif
-}
+ }
/*
* Trace routine to pick up changes in the values of the message buffer
* sizes
*/
-DPRIVATE char * DtclTraceRoutine(ClientData clientData,
- Tcl_Interp *interpt, char *name1, char *name2 DUNUSED,
- int flags)
-{
- DtclContextType *context = (DtclContextType *)clientData;
- char *value = Tcl_GetVar(interpt, name1, flags);
+ DPRIVATE char * DtclTraceRoutine(ClientData clientData,
+ Tcl_Interp *interpt, char *name1, char *name2 DUNUSED,
+ int flags)
+ {
+ DtclContextType *context = (DtclContextType *)clientData;
+ char *value = Tcl_GetVar(interpt, name1, flags);
/*
* Handle namespace qualification
*/
- if (strncmp(name1,"drama::",7) == 0)
- name1 = &name1[7];
+ if (strncmp(name1,"drama::",7) == 0)
+ name1 = &name1[7];
- if (strcmp(name1,"MessageBytes") == 0)
- {
- context->MessageBytes = atol(value);
- }
- else if (strcmp(name1,"MaxMessages") == 0)
- {
- context->MaxMessages = atol(value);
- }
- else if (strcmp(name1,"ReplyBytes") == 0)
- {
- context->ReplyBytes = atol(value);
- }
- else if (strcmp(name1,"MaxReplies") == 0)
- {
- context->MaxReplies = atol(value);
- }
- else if (strcmp(name1,"Logging") == 0)
- {
- context->Logging = atol(value);
- }
- else
- {
- StatusType status = STATUS__OK;
- ErsOut(0,&status,"DtclTraceRoutine:Called for unknown variable %s",
- name1);
- }
+ if (strcmp(name1,"MessageBytes") == 0)
+ {
+ context->MessageBytes = atol(value);
+ }
+ else if (strcmp(name1,"MaxMessages") == 0)
+ {
+ context->MaxMessages = atol(value);
+ }
+ else if (strcmp(name1,"ReplyBytes") == 0)
+ {
+ context->ReplyBytes = atol(value);
+ }
+ else if (strcmp(name1,"MaxReplies") == 0)
+ {
+ context->MaxReplies = atol(value);
+ }
+ else if (strcmp(name1,"Logging") == 0)
+ {
+ context->Logging = atol(value);
+ }
+ else
+ {
+ StatusType status = STATUS__OK;
+ ErsOut(0,&status,"DtclTraceRoutine:Called for unknown variable %s",
+ name1);
+ }
- return(0);
-}
+ return(0);
+ }
/*
* Setup a single DRAMA integer variable trace. IF the variable does
* not have a current value, then we must set it. If it does have a current
* value which is an integer, we use it.
*/
-DPRIVATE DVOID DtclSetupSingleVar(char * variable,
- long int * value,
- DtclContextType *context)
-{
- Tcl_DString dString;
- char *cvalue;
- int set = 0;
+ DPRIVATE DVOID DtclSetupSingleVar(char * variable,
+ long int * value,
+ DtclContextType *context)
+ {
+ Tcl_DString dString;
+ char *cvalue;
+ int set = 0;
- Tcl_DStringInit(&dString);
+ Tcl_DStringInit(&dString);
#if TCL_MAJOR_VERSION >= 8
- Tcl_DStringAppend(&dString,"drama::",-1);
+ Tcl_DStringAppend(&dString,"drama::",-1);
#endif
- Tcl_DStringAppend(&dString,(char *)variable,-1);
+ Tcl_DStringAppend(&dString,(char *)variable,-1);
/*
* Get the current value.
*/
- cvalue = Tcl_GetVar(context->interp,
- Tcl_DStringValue(&dString),
- TCL_GLOBAL_ONLY);
- if (cvalue)
- {
+ cvalue = Tcl_GetVar(context->interp,
+ Tcl_DStringValue(&dString),
+ TCL_GLOBAL_ONLY);
+ if (cvalue)
+ {
/*
* If current value is integer, use it, otherwise we must reset it.
*/
- int ivalue;
- if (Tcl_GetInt(context->interp, cvalue, &ivalue) == TCL_ERROR)
- {
- fprintf(stderr,
- "DRAMA Variable %s has non-integer value \"%s\", reseting\n",
- variable,cvalue);
- set = 1;
+ int ivalue;
+ if (Tcl_GetInt(context->interp, cvalue, &ivalue) == TCL_ERROR)
+ {
+ fprintf(stderr,
+ "DRAMA Variable %s has non-integer value \"%s\", reseting\n",
+ variable,cvalue);
+ set = 1;
+ }
+ else
+ *value = ivalue;
}
- else
- *value = ivalue;
- }
- else
- set = 1;
+ else
+ set = 1;
/*
* If we need to set the Tcl variable, do so.
*/
- if (set)
- {
- char buffer[20];
+ if (set)
+ {
+ char buffer[20];
- sprintf(buffer,"%ld",*value);
- Tcl_SetVar(context->interp,
- Tcl_DStringValue(&dString),
- buffer, TCL_GLOBAL_ONLY);
- }
+ sprintf(buffer,"%ld",*value);
+ Tcl_SetVar(context->interp,
+ Tcl_DStringValue(&dString),
+ buffer, TCL_GLOBAL_ONLY);
+ }
/*
* Setup trace.
*/
- Tcl_TraceVar(context->interp,
- Tcl_DStringValue(&dString),
- TCL_TRACE_WRITES|TCL_GLOBAL_ONLY,
- DtclTraceRoutine,(ClientData)context);
+ Tcl_TraceVar(context->interp,
+ Tcl_DStringValue(&dString),
+ TCL_TRACE_WRITES|TCL_GLOBAL_ONLY,
+ DtclTraceRoutine,(ClientData)context);
- Tcl_DStringFree(&dString);
-}
+ Tcl_DStringFree(&dString);
+ }
@@ -4860,111 +4896,111 @@ DPRIVATE DVOID DtclSetupSingleVar(char * variable,
* so that we can pick up changes. This is more efficent then to read the
* value each time. Also setup the DramaVersion and DtclVersion variables
*/
-DINTERNAL DVOID DtclSetupVars(DtclContextType *context)
-{
-#if TCL_MAJOR_VERSION >= 8
- char *command = "namespace eval drama { variable MessageBytes ; variable MaxMessages ; variable ReplyBytes ; variable MaxReplies ; variable Logging ; variable DramaVersion ; variable DramaVerName ; variable DtclVersion }";
- int result;
- result = Tcl_Eval(context->interp,command);
- if (result != TCL_OK)
+ DINTERNAL DVOID DtclSetupVars(DtclContextType *context)
{
- StatusType status = DTCL__INITSCRIPT;
- DtclErsRep(context->interp,1,&status);
- ErsRep(0,&status,"Error creating variables in namespace");
- ErsFlush(&status);
- return;
- }
+#if TCL_MAJOR_VERSION >= 8
+ char *command = "namespace eval drama { variable MessageBytes ; variable MaxMessages ; variable ReplyBytes ; variable MaxReplies ; variable Logging ; variable DramaVersion ; variable DramaVerName ; variable DtclVersion }";
+ int result;
+ result = Tcl_Eval(context->interp,command);
+ if (result != TCL_OK)
+ {
+ StatusType status = DTCL__INITSCRIPT;
+ DtclErsRep(context->interp,1,&status);
+ ErsRep(0,&status,"Error creating variables in namespace");
+ ErsFlush(&status);
+ return;
+ }
# endif
/*
* Setup each of the traces. note, if the variable already has a
* value defined (possible when using Dtcl sharable value) then we
* use the specified value rather then reseting the value.
*/
- DtclSetupSingleVar("MessageBytes", &context->MessageBytes, context);
- DtclSetupSingleVar("MaxMessages", &context->MaxMessages, context);
- DtclSetupSingleVar("ReplyBytes", &context->ReplyBytes, context);
- DtclSetupSingleVar("MaxReplies", &context->MaxReplies, context);
- DtclSetupSingleVar("Logging", &context->Logging, context);
+ DtclSetupSingleVar("MessageBytes", &context->MessageBytes, context);
+ DtclSetupSingleVar("MaxMessages", &context->MaxMessages, context);
+ DtclSetupSingleVar("ReplyBytes", &context->ReplyBytes, context);
+ DtclSetupSingleVar("MaxReplies", &context->MaxReplies, context);
+ DtclSetupSingleVar("Logging", &context->Logging, context);
#if TCL_MAJOR_VERSION >= 8
- Tcl_SetVar(context->interp, "drama::DramaVersion", DRAMA_VERSION, TCL_GLOBAL_ONLY);
+ Tcl_SetVar(context->interp, "drama::DramaVersion", DRAMA_VERSION, TCL_GLOBAL_ONLY);
# ifdef DRAMA_VERNAME
- Tcl_SetVar(context->interp, "drama::DramaVerName", DRAMA_VERNAME, TCL_GLOBAL_ONLY);
+ Tcl_SetVar(context->interp, "drama::DramaVerName", DRAMA_VERNAME, TCL_GLOBAL_ONLY);
# endif
- Tcl_SetVar(context->interp, "drama::DtclVersion", DTCL_VERSION, TCL_GLOBAL_ONLY);
+ Tcl_SetVar(context->interp, "drama::DtclVersion", DTCL_VERSION, TCL_GLOBAL_ONLY);
#else
- Tcl_SetVar(context->interp, "DramaVersion", DRAMA_VERSION, TCL_GLOBAL_ONLY);
+ Tcl_SetVar(context->interp, "DramaVersion", DRAMA_VERSION, TCL_GLOBAL_ONLY);
# ifdef DRAMA_VERNAME
- Tcl_SetVar(context->interp, "DramaVerName", DRAMA_VERNAME, TCL_GLOBAL_ONLY);
+ Tcl_SetVar(context->interp, "DramaVerName", DRAMA_VERNAME, TCL_GLOBAL_ONLY);
# endif
- Tcl_SetVar(context->interp, "DtclVersion", DTCL_VERSION, TCL_GLOBAL_ONLY);
+ Tcl_SetVar(context->interp, "DtclVersion", DTCL_VERSION, TCL_GLOBAL_ONLY);
#endif
-}
+ }
/*
* * * * * * * * * * * * * * * * * * * * * * * * * * ** * * * * * * * * *
*/
-DINTERNAL DVOID DtclInvokeOldCmdDef(Tcl_Interp *interp,
- DVOIDP clientData,
- StatusType *status)
-{
- if (clientData)
+ DINTERNAL DVOID DtclInvokeOldCmdDef(Tcl_Interp *interp,
+ DVOIDP clientData,
+ StatusType *status)
{
- ((DtclCommandDefnType)(clientData))(interp,status);
+ if (clientData)
+ {
+ ((DtclCommandDefnType)(clientData))(interp,status);
+ }
}
-}
/*
* * * * * * * * * * * * * * * * * * * * * * * * * * ** * * * * * * * * *
*+ D t c l E r r o r
* Command name:
- DtclError
+ DtclError
* Function:
- Command invoked to process background errors.
+ Command invoked to process background errors.
* Description:
- The DtclError command doesn't exist as a built-in part of Dtcl.
- Instead, individual applications or users can define a DtclError
- command (e.g. as a Tcl procedure) if they wish to handle background
- errors. A Dtcl background error is one that occurs in a command that
- occurs while executing a specified handler command to a Dtcl
- command. For example, the success and error handlers to the Dtcl
- obey command. For a non-background error, the error can simply be
- returned up through nested Tcl command evaluations until it reaches
- the top-level code in the application; then the application can
- report the error in whatever way it wishes. When a background error
- occurs, the unwinding ends in the Dtcl library and there is no obvious
- way for Dtcl to report the error.
-
- When Dtcl detects a background error, it invokes the the DtclError
- command, passing it the error message as its only argument. Dtcl
- assumes that the application has implemented the DtclError command,
- and that the command will report the error in a way that makes sense
- for the application. Dtcl will ignore any result returned by the
- DtclError command. If another Tcl error occurs within the DtclError
- command then Dtcl reports the error itself using Ers.
-
- This form of error handling is almost exactly the same as is done
- by tk (see tkerror).
-
- The Tk version of Dtcl includes a default DtclError procedure that
- behaves in a similar way to the default version of tkerror. It posts
- a dialog box containing the error message and offers the user a
- chance to see a stack trace that shows where the error occurred.
-
- In a call to DtclError, the stack is found in
- the global variable errorInfo.
+ The DtclError command doesn't exist as a built-in part of Dtcl.
+ Instead, individual applications or users can define a DtclError
+ command (e.g. as a Tcl procedure) if they wish to handle background
+ errors. A Dtcl background error is one that occurs in a command that
+ occurs while executing a specified handler command to a Dtcl
+ command. For example, the success and error handlers to the Dtcl
+ obey command. For a non-background error, the error can simply be
+ returned up through nested Tcl command evaluations until it reaches
+ the top-level code in the application; then the application can
+ report the error in whatever way it wishes. When a background error
+ occurs, the unwinding ends in the Dtcl library and there is no obvious
+ way for Dtcl to report the error.
+
+ When Dtcl detects a background error, it invokes the the DtclError
+ command, passing it the error message as its only argument. Dtcl
+ assumes that the application has implemented the DtclError command,
+ and that the command will report the error in a way that makes sense
+ for the application. Dtcl will ignore any result returned by the
+ DtclError command. If another Tcl error occurs within the DtclError
+ command then Dtcl reports the error itself using Ers.
+
+ This form of error handling is almost exactly the same as is done
+ by tk (see tkerror).
+
+ The Tk version of Dtcl includes a default DtclError procedure that
+ behaves in a similar way to the default version of tkerror. It posts
+ a dialog box containing the error message and offers the user a
+ chance to see a stack trace that shows where the error occurred.
+
+ In a call to DtclError, the stack is found in
+ the global variable errorInfo.
* Call:
- DtclError message
+ DtclError message
* Parameters:
- (>) message (string) The error message
+ (>) message (string) The error message
* Language:
- Tcl
+ Tcl
* See Also: DTCL manual, DtclBackgroundError(3), tkerror(n).
@@ -4973,8 +5009,8 @@ DINTERNAL DVOID DtclInvokeOldCmdDef(Tcl_Interp *interp,
*-
* History:
- 20-Jun-1994 - TJF - Original version
- */
+ 20-Jun-1994 - TJF - Original version
+*/
/*
@@ -4988,26 +5024,26 @@ DINTERNAL DVOID DtclInvokeOldCmdDef(Tcl_Interp *interp,
* To use namespace, we must have Tcl version 8.0 or higher.
*/
-DINTERNAL DVOIDF Dtcl___CreateCommand(
- Tcl_Interp *interp,
- DCONSTV char * DCONSTR name,
- Tcl_CmdProc *proc,
- DVOIDP clientData,
- Tcl_CmdDeleteProc *deleteProc)
-{
- Tcl_DString dString;
+ DINTERNAL DVOIDF Dtcl___CreateCommand(
+ Tcl_Interp *interp,
+ DCONSTV char * DCONSTR name,
+ Tcl_CmdProc *proc,
+ DVOIDP clientData,
+ Tcl_CmdDeleteProc *deleteProc)
+ {
+ Tcl_DString dString;
- Tcl_DStringInit(&dString);
+ Tcl_DStringInit(&dString);
#if TCL_MAJOR_VERSION >= 8
- Tcl_DStringAppend(&dString,"drama::",-1);
+ Tcl_DStringAppend(&dString,"drama::",-1);
#endif
- Tcl_DStringAppend(&dString,(char *)name,-1);
+ Tcl_DStringAppend(&dString,(char *)name,-1);
- Tcl_CreateCommand(interp, Tcl_DStringValue(&dString),
- proc, clientData, deleteProc);
- Tcl_DStringFree(&dString);
-}
+ Tcl_CreateCommand(interp, Tcl_DStringValue(&dString),
+ proc, clientData, deleteProc);
+ Tcl_DStringFree(&dString);
+ }
/*
@@ -5021,26 +5057,26 @@ DINTERNAL DVOIDF Dtcl___CreateCommand(
* To use namespace, we must have Tcl version 8.0 or higher.
*/
-DINTERNAL DVOIDF Dtcl___CreateObjCommand(
- Tcl_Interp *interp,
- DCONSTV char * DCONSTR name,
- Tcl_ObjCmdProc *proc,
- DVOIDP clientData,
- Tcl_CmdDeleteProc *deleteProc)
-{
- Tcl_DString dString;
+ DINTERNAL DVOIDF Dtcl___CreateObjCommand(
+ Tcl_Interp *interp,
+ DCONSTV char * DCONSTR name,
+ Tcl_ObjCmdProc *proc,
+ DVOIDP clientData,
+ Tcl_CmdDeleteProc *deleteProc)
+ {
+ Tcl_DString dString;
- Tcl_DStringInit(&dString);
+ Tcl_DStringInit(&dString);
#if TCL_MAJOR_VERSION >= 8
- Tcl_DStringAppend(&dString,"drama::",-1);
+ Tcl_DStringAppend(&dString,"drama::",-1);
#endif
- Tcl_DStringAppend(&dString,(char *)name,-1);
+ Tcl_DStringAppend(&dString,(char *)name,-1);
- Tcl_CreateObjCommand(interp, Tcl_DStringValue(&dString),
- proc, clientData, deleteProc);
- Tcl_DStringFree(&dString);
-}
+ Tcl_CreateObjCommand(interp, Tcl_DStringValue(&dString),
+ proc, clientData, deleteProc);
+ Tcl_DStringFree(&dString);
+ }
/*
* D t c l _ _ _ N a m e s p a c e I n i t
@@ -5074,117 +5110,117 @@ DINTERNAL DVOIDF Dtcl___CreateObjCommand(
*
*/
#if TCL_MAJOR_VERSION >= 8
-DPRIVATE DVOIDF Dtcl___EvalCommand(
- Tcl_Interp *interp,
- char * cmd)
-{
- int result;
- result = Tcl_Eval(interp,cmd);
- if (result != TCL_OK)
- {
- StatusType status = DTCL__INITSCRIPT;
- DtclErsRep(interp,1,&status);
- ErsFlush(&status);
- return;
+ DPRIVATE DVOIDF Dtcl___EvalCommand(
+ Tcl_Interp *interp,
+ char * cmd)
+ {
+ int result;
+ result = Tcl_Eval(interp,cmd);
+ if (result != TCL_OK)
+ {
+ StatusType status = DTCL__INITSCRIPT;
+ DtclErsRep(interp,1,&status);
+ ErsFlush(&status);
+ return;
+ }
}
-}
#endif
-DINTERNAL DVOIDF Dtcl___NamespaceInit(
- Tcl_Interp *interp DUNUSED,
- int forceGlobalNamespace DUNUSED,/*negative = not set, 0 = false, postive = true */
- StatusType *status)
-{
- if (*status != STATUS__OK) return;
-# if TCL_MAJOR_VERSION >= 8
+ DINTERNAL DVOIDF Dtcl___NamespaceInit(
+ Tcl_Interp *interp DUNUSED,
+ int forceGlobalNamespace DUNUSED,/*negative = not set, 0 = false, postive = true */
+ StatusType *status)
{
- int useNamespaces = Dtcl___NamespaceUseCheck(forceGlobalNamespace,
- status);
+ if (*status != STATUS__OK) return;
+# if TCL_MAJOR_VERSION >= 8
+ {
+ int useNamespaces = Dtcl___NamespaceUseCheck(forceGlobalNamespace,
+ status);
/*
* For this version of TCL, namespace useage is the default. If
* we don't want to force the use of namespaces, we must make all the
* DRAMA commands and variables global. Note, the namespace versions
* still exist, allowing other bits of the code to use them.
*/
- if (!useNamespaces)
- {
- char *cmd1 = "namespace eval drama { namespace export * }";
- char *cmd2 = "namespace import drama::*";
- char *cmd3 = "upvar #0 drama::MessageBytes MessageBytes";
- char *cmd4 = "upvar #0 drama::MaxMessages MaxMessages";
- char *cmd5 = "upvar #0 drama::ReplyBytes ReplyBytes";
- char *cmd6 = "upvar #0 drama::MaxReplies MaxReplies";
- char *cmd7 = "upvar #0 drama::Logging Logging";
- char *cmd8 = "upvar #0 drama::DramaVersion DramaVersion";
- char *cmd9 = "upvar #0 drama::DramaVerName DramaVerName";
- char *cmd10 ="upvar #0 drama::DtclVersion DtclVersion";
-
- Dtcl___EvalCommand(interp,cmd1);
- Dtcl___EvalCommand(interp,cmd2);
- Dtcl___EvalCommand(interp,cmd3);
- Dtcl___EvalCommand(interp,cmd4);
- Dtcl___EvalCommand(interp,cmd5);
- Dtcl___EvalCommand(interp,cmd6);
- Dtcl___EvalCommand(interp,cmd7);
- Dtcl___EvalCommand(interp,cmd8);
- Dtcl___EvalCommand(interp,cmd9);
- Dtcl___EvalCommand(interp,cmd10);
+ if (!useNamespaces)
+ {
+ char *cmd1 = "namespace eval drama { namespace export * }";
+ char *cmd2 = "namespace import drama::*";
+ char *cmd3 = "upvar #0 drama::MessageBytes MessageBytes";
+ char *cmd4 = "upvar #0 drama::MaxMessages MaxMessages";
+ char *cmd5 = "upvar #0 drama::ReplyBytes ReplyBytes";
+ char *cmd6 = "upvar #0 drama::MaxReplies MaxReplies";
+ char *cmd7 = "upvar #0 drama::Logging Logging";
+ char *cmd8 = "upvar #0 drama::DramaVersion DramaVersion";
+ char *cmd9 = "upvar #0 drama::DramaVerName DramaVerName";
+ char *cmd10 ="upvar #0 drama::DtclVersion DtclVersion";
+
+ Dtcl___EvalCommand(interp,cmd1);
+ Dtcl___EvalCommand(interp,cmd2);
+ Dtcl___EvalCommand(interp,cmd3);
+ Dtcl___EvalCommand(interp,cmd4);
+ Dtcl___EvalCommand(interp,cmd5);
+ Dtcl___EvalCommand(interp,cmd6);
+ Dtcl___EvalCommand(interp,cmd7);
+ Dtcl___EvalCommand(interp,cmd8);
+ Dtcl___EvalCommand(interp,cmd9);
+ Dtcl___EvalCommand(interp,cmd10);
+ }
}
- }
# endif
-}
+ }
-DINTERNAL int Dtcl___NamespaceUseCheck(
- int forceGlobalNamespace DUNUSED,
- StatusType *status DUNUSED)
-{
+ DINTERNAL int Dtcl___NamespaceUseCheck(
+ int forceGlobalNamespace DUNUSED,
+ StatusType *status DUNUSED)
+ {
#if TCL_MAJOR_VERSION < 8
- return 0;
+ return 0;
#else
- char value[20];
+ char value[20];
#if DTCL_GLOBAL_NAMESPACE
- int useNamespaces = 0;
+ int useNamespaces = 0;
#else
- int useNamespaces = 1;
+ int useNamespaces = 1;
#endif
- if (*status != STATUS__OK) return 1;
+ if (*status != STATUS__OK) return 1;
- if (forceGlobalNamespace < 0)
- {
- if (DitsGetSymbol("DTCL_NAMESPACES", value, sizeof(value)) != 0)
- useNamespaces = atol(value);
- return useNamespaces;
- }
- else if (forceGlobalNamespace == 0)
- return(1);
- else /* (forceGlobalNamespace > 0) */
- return(0);
+ if (forceGlobalNamespace < 0)
+ {
+ if (DitsGetSymbol("DTCL_NAMESPACES", value, sizeof(value)) != 0)
+ useNamespaces = atol(value);
+ return useNamespaces;
+ }
+ else if (forceGlobalNamespace == 0)
+ return(1);
+ else /* (forceGlobalNamespace > 0) */
+ return(0);
#endif
-}
+ }
/*
* Intialise various parts of a Dtcl context variable.
*/
-DINTERNAL DVOIDF Dtcl___ContextInit(
- DtclContextType *DtclContext,
- StatusType *status)
-{
- if (*status != STATUS__OK) return;
-
- DtclContext->Logging = 0;
- DtclContext->ErsHandler = NULL;
- DtclContext->MsgHandler = NULL;
- DtclContext->DisconHandler = NULL;
- DtclContext->OldDisconRoutine = NULL;
- DtclContext->ConnectHandler = NULL;
- DtclContext->OldConnectRoutine = NULL;
+ DINTERNAL DVOIDF Dtcl___ContextInit(
+ DtclContextType *DtclContext,
+ StatusType *status)
+ {
+ if (*status != STATUS__OK) return;
+
+ DtclContext->Logging = 0;
+ DtclContext->ErsHandler = NULL;
+ DtclContext->MsgHandler = NULL;
+ DtclContext->DisconHandler = NULL;
+ DtclContext->OldDisconRoutine = NULL;
+ DtclContext->ConnectHandler = NULL;
+ DtclContext->OldConnectRoutine = NULL;
#ifdef DITS_M_REGISTRAR
- DtclContext->RegistrationHandler = NULL;
- DtclContext->OldRegistrationRoutine = NULL;
+ DtclContext->RegistrationHandler = NULL;
+ DtclContext->OldRegistrationRoutine = NULL;
#endif
-}
+ }
--
GitLab