/*
* tclXgeneral.c --
*
* A collection of general commands: echo, infox and loop.
*-----------------------------------------------------------------------------
* Copyright 1991-1999 Karl Lehenbauer and Mark Diekhans.
*
* Permission to use, copy, modify, and distribute this software and its
* documentation for any purpose and without fee is hereby granted, provided
* that the above copyright notice appear in all copies. Karl Lehenbauer and
* Mark Diekhans make no representations about the suitability of this
* software for any purpose. It is provided "as is" without express or
* implied warranty.
*-----------------------------------------------------------------------------
* $Id: tclXgeneral.c,v 1.3 2002/04/04 06:09:05 hobbs Exp $
*-----------------------------------------------------------------------------
*/
#include "tclExtdInt.h"
/*
* Values returned by the infox command.
*/
static char *tclxVersion = FULL_VERSION;
static int tclxPatchlevel = TCLX_PATCHLEVEL;
static char *tclAppName = NULL;
static char *tclAppLongName = NULL;
static char *tclAppVersion = NULL;
static int tclAppPatchlevel = -1;
static int
TclX_EchoObjCmd (ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[]);
static int
TclX_InfoxObjCmd (ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[]);
static int
TclX_LoopObjCmd (ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[]);
static int
SetLoopCounter (Tcl_Interp *interp,
char *varName,
int idx);
static int
GlobalImport (Tcl_Interp *interp);
static int
TclX_Try_EvalObjCmd (ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[]);
/*-----------------------------------------------------------------------------
* TclX_SetAppInfo --
* Store the application information returned by infox.
*
* Parameters:
* o defaultValues (I) - If true, then the values are assigned only if they
* are not already defined (defaulted). If false, the values are always
* set.
* o appName (I) - Application symbolic name.
* o appLongName (I) - Long, natural language application name.
* o appVersion (I) - Version number of the application.
* o appPatchlevel (I) - Patch level of the application. If less than
* zero, don't change.
* Notes:
* String pointers are saved without copying, don't release the memory.
* If the arguments are NULL, don't change the values.
*-----------------------------------------------------------------------------
*/
void
TclX_SetAppInfo (int defaultValues,
char *appName,
char *appLongName,
char *appVersion,
int appPatchlevel)
{
if ((appName != NULL) &&
((!defaultValues) || (tclAppName == NULL))) {
tclAppName = appName;
}
if ((appLongName != NULL) &&
((!defaultValues) || (tclAppLongName == NULL))) {
tclAppLongName = appLongName;
}
if ((appVersion != NULL) &&
((!defaultValues) || (tclAppVersion == NULL))) {
tclAppVersion = appVersion;
}
if ((appPatchlevel >= 0) &&
((!defaultValues) || (tclAppPatchlevel < 0))) {
tclAppPatchlevel = appPatchlevel;
}
}
/*-----------------------------------------------------------------------------
* TclX_EchoObjCmd --
* Implements the TclX echo command:
* echo ?str ...?
*
* Results:
* Always returns TCL_OK.
*-----------------------------------------------------------------------------
*/
static int
TclX_EchoObjCmd (ClientData dummy,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
int idx;
Tcl_Channel channel;
#ifndef TCL_UTF_MAX
char *stringPtr;
int stringPtrLen;
#endif
channel = TclX_GetOpenChannel (interp, "stdout", TCL_WRITABLE);
if (channel == NULL)
return TCL_ERROR;
for (idx = 1; idx < objc; idx++) {
#ifndef TCL_UTF_MAX
stringPtr = Tcl_GetStringFromObj (objv [idx], &stringPtrLen);
if (Tcl_Write (channel, stringPtr, stringPtrLen) < 0)
#else
if (Tcl_WriteObj(channel, objv[idx]) < 0)
#endif
goto posixError;
if (idx < (objc - 1)) {
if (Tcl_Write (channel, " ", 1) < 0)
goto posixError;
}
}
if (TclX_WriteNL (channel) < 0)
goto posixError;
return TCL_OK;
posixError:
Tcl_SetStringObj (Tcl_GetObjResult (interp), Tcl_PosixError (interp), -1);
return TCL_ERROR;
}
/*-----------------------------------------------------------------------------
* TclX_InfoxObjCmd --
* Implements the TclX infox command:
* infox option
*-----------------------------------------------------------------------------
*/
static int
TclX_InfoxObjCmd (ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *resultPtr = Tcl_GetObjResult (interp);
char *optionPtr;
/*
* FIX: Need a way to get the have_ functionality from the OS-dependent
* code.
*/
if (objc != 2) {
return TclX_WrongArgs (interp, objv[0], "option");
}
optionPtr = Tcl_GetStringFromObj (objv[1], NULL);
if (STREQU ("version", optionPtr)) {
if (tclxVersion != NULL) {
Tcl_SetStringObj (resultPtr, tclxVersion, -1);
}
return TCL_OK;
}
if (STREQU ("patchlevel", optionPtr)) {
Tcl_SetIntObj (resultPtr, tclxPatchlevel);
return TCL_OK;
}
if (STREQU ("have_fchown", optionPtr)) {
# ifndef NO_FCHOWN
Tcl_SetBooleanObj (resultPtr, TRUE);
# else
Tcl_SetBooleanObj (resultPtr, FALSE);
# endif
return TCL_OK;
}
if (STREQU ("have_fchmod", optionPtr)) {
# ifndef NO_FCHMOD
Tcl_SetBooleanObj (resultPtr, TRUE);
# else
Tcl_SetBooleanObj (resultPtr, FALSE);
# endif
return TCL_OK;
}
if (STREQU ("have_flock", optionPtr)) {
if (TclXOSHaveFlock ())
Tcl_SetBooleanObj (resultPtr, TRUE);
else
Tcl_SetBooleanObj (resultPtr, FALSE);
return TCL_OK;
}
if (STREQU ("have_fsync", optionPtr)) {
# ifndef NO_FSYNC
Tcl_SetBooleanObj (resultPtr, TRUE);
# else
Tcl_SetBooleanObj (resultPtr, FALSE);
# endif
return TCL_OK;
}
if (STREQU ("have_ftruncate", optionPtr)) {
# if (!defined(NO_FTRUNCATE)) || defined(HAVE_CHSIZE)
Tcl_SetBooleanObj (resultPtr, TRUE);
# else
Tcl_SetBooleanObj (resultPtr, FALSE);
# endif
return TCL_OK;
}
if (STREQU ("have_msgcats", optionPtr)) {
# ifndef NO_CATGETS
Tcl_SetBooleanObj (resultPtr, TRUE);
# else
Tcl_SetBooleanObj (resultPtr, FALSE);
# endif
return TCL_OK;
}
if (STREQU ("have_posix_signals", optionPtr)) {
# ifndef NO_SIGACTION
Tcl_SetBooleanObj (resultPtr, TRUE);
# else
Tcl_SetBooleanObj (resultPtr, FALSE);
# endif
return TCL_OK;
}
if (STREQU ("have_signal_restart", optionPtr)) {
# ifndef NO_SIG_RESTART
Tcl_SetBooleanObj (resultPtr, TRUE);
# else
Tcl_SetBooleanObj (resultPtr, FALSE);
# endif
return TCL_OK;
}
if (STREQU ("have_truncate", optionPtr)) {
# ifndef NO_TRUNCATE
Tcl_SetBooleanObj (resultPtr, TRUE);
# else
Tcl_SetBooleanObj (resultPtr, FALSE);
# endif
return TCL_OK;
}
if (STREQU ("have_symlink", optionPtr)) {
# ifdef S_IFLNK
Tcl_SetBooleanObj (resultPtr, TRUE);
# else
Tcl_SetBooleanObj (resultPtr, FALSE);
# endif
return TCL_OK;
}
if (STREQU ("have_waitpid", optionPtr)) {
# ifndef NO_WAITPID
Tcl_SetBooleanObj (resultPtr, TRUE);
# else
Tcl_SetBooleanObj (resultPtr, FALSE);
# endif
return TCL_OK;
}
if (STREQU ("appname", optionPtr)) {
if (tclAppName != NULL) {
Tcl_SetStringObj (resultPtr, tclAppName, -1);
}
return TCL_OK;
}
if (STREQU ("applongname", optionPtr)) {
if (tclAppLongName != NULL)
Tcl_SetStringObj (resultPtr, tclAppLongName, -1);
return TCL_OK;
}
if (STREQU ("appversion", optionPtr)) {
if (tclAppVersion != NULL)
Tcl_SetStringObj (resultPtr, tclAppVersion, -1);
return TCL_OK;
}
if (STREQU ("apppatchlevel", optionPtr)) {
if (tclAppPatchlevel >= 0)
Tcl_SetIntObj (resultPtr, tclAppPatchlevel);
else
Tcl_SetIntObj (resultPtr, 0);
return TCL_OK;
}
TclX_AppendObjResult (interp, "illegal option \"", optionPtr,
"\", expect one of: version, patchlevel, ",
"have_fchown, have_fchmod, have_flock, ",
"have_fsync, have_ftruncate, have_msgcats, ",
"have_symlink, have_truncate, ",
"have_posix_signals, have_waitpid, appname, ",
"applongname, appversion, or apppatchlevel",
(char *) NULL);
return TCL_ERROR;
}
/*-----------------------------------------------------------------------------
* SetLoopCounter --
* Set the loop command counter variable.
*-----------------------------------------------------------------------------
*/
static int
SetLoopCounter (Tcl_Interp *interp, char *varName, int idx)
{
Tcl_Obj *iObj, *newVarObj;
iObj = Tcl_GetVar2Ex(interp, varName, NULL, TCL_PARSE_PART1);
if ((iObj == NULL) || (Tcl_IsShared (iObj))) {
iObj = newVarObj = Tcl_NewLongObj (idx);
} else {
newVarObj = NULL;
}
Tcl_SetLongObj (iObj, idx);
if (Tcl_SetVar2Ex(interp, varName, NULL, iObj,
TCL_PARSE_PART1|TCL_LEAVE_ERR_MSG) == NULL) {
if (newVarObj != NULL) {
Tcl_DecrRefCount (newVarObj);
}
return TCL_ERROR;
}
return TCL_OK;
}
/*-----------------------------------------------------------------------------
* TclX_LoopObjCmd --
* Implements the TclX loop command:
* loop var start end ?increment? command
*
* Results:
* Standard TCL results.
*-----------------------------------------------------------------------------
*/
static int
TclX_LoopObjCmd (ClientData dummy,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
int result = TCL_OK;
long idx, first, limit, incr = 1;
char *varName;
Tcl_Obj *command;
if ((objc < 5) || (objc > 6)) {
return TclX_WrongArgs (interp, objv [0],
"var first limit ?incr? command");
}
if (Tcl_ExprLongObj (interp, objv [2], &first) != TCL_OK)
return TCL_ERROR;
if (Tcl_ExprLongObj (interp, objv [3], &limit) != TCL_OK)
return TCL_ERROR;
if (objc == 5) {
command = objv [4];
} else {
if (Tcl_ExprLongObj (interp, objv [4], &incr) != TCL_OK)
return TCL_ERROR;
command = objv [5];
}
varName = Tcl_GetStringFromObj (objv[1], NULL);
for (idx = first;
(((idx < limit) && (incr >= 0)) || ((idx > limit) && (incr < 0)));
idx += incr) {
if (SetLoopCounter(interp, varName, idx) == TCL_ERROR)
return TCL_ERROR;
result = Tcl_EvalObj (interp, command);
if (result == TCL_CONTINUE) {
result = TCL_OK;
} else if (result != TCL_OK) {
if (result == TCL_BREAK) {
result = TCL_OK;
} else if (result == TCL_ERROR) {
char buf [64];
sprintf (buf, "\n (\"loop\" body line %d)",
ERRORLINE(interp));
Tcl_AddErrorInfo (interp, buf);
}
break;
}
}
/*
* Set loop counter to its final value.
*/
if (SetLoopCounter(interp, varName, idx) == TCL_ERROR)
return TCL_ERROR;
return result;
}
/*-----------------------------------------------------------------------------
* GlobalImport --
* Import the errorResult, errorInfo, and errorCode global variable into the
* current environment by calling the global command directly.
*
* Parameters:
* o interp (I) - Current interpreter, Result is preserved.
* Returns:
* TCL_OK or TCL_ERROR.
*-----------------------------------------------------------------------------
*/
static int
GlobalImport (Tcl_Interp *interp)
{
static char global [] = "global";
Tcl_Obj *savedResult;
Tcl_CmdInfo cmdInfo;
#define globalObjc (4)
Tcl_Obj *globalObjv [globalObjc];
int idx, code = TCL_OK;
savedResult = Tcl_DuplicateObj (Tcl_GetObjResult (interp));
if (!Tcl_GetCommandInfo (interp, global, &cmdInfo)) {
TclX_AppendObjResult (interp, "can't find \"global\" command",
(char *) NULL);
goto errorExit;
}
globalObjv [0] = Tcl_NewStringObj (global, -1);
globalObjv [1] = Tcl_NewStringObj ("errorResult", -1);
globalObjv [2] = Tcl_NewStringObj ("errorInfo", -1);
globalObjv [3] = Tcl_NewStringObj ("errorCode", -1);
for (idx = 0; idx < globalObjc; idx++) {
Tcl_IncrRefCount (globalObjv [idx]);
}
code = (*cmdInfo.objProc) (cmdInfo.objClientData,
interp,
globalObjc,
globalObjv);
for (idx = 0; idx < globalObjc; idx++) {
Tcl_DecrRefCount (globalObjv [idx]);
}
if (code == TCL_ERROR)
goto errorExit;
Tcl_SetObjResult (interp, savedResult);
return TCL_OK;
errorExit:
Tcl_DecrRefCount (savedResult);
return TCL_ERROR;
}
/*-----------------------------------------------------------------------------
* TclX_Try_EvalObjCmd --
* Implements the TclX try_eval command:
* try_eval code catch ?finally?
*
* Results:
* Standard TCL results.
*-----------------------------------------------------------------------------
*/
static int
TclX_Try_EvalObjCmd (ClientData dummy,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
int code, code2;
int haveFinally;
Tcl_Obj *savedResultsPtr, *resultObjPtr;
if ((objc < 3) || (objc > 4)) {
return TclX_WrongArgs (interp, objv [0], "code catch ?finally?");
}
haveFinally = (objc >= 4) && !TclX_IsNullObj (objv [3]);
/*
* Evaluate the command. If not error and no finally command, we are done.
*/
code = Tcl_EvalObj (interp, objv [1]);
if ((code != TCL_ERROR) && !haveFinally) {
return code;
}
/*
* Process error block, if available. It's results becomes the command's
* result.
*/
if ((!TclX_IsNullObj (objv [2])) && (code == TCL_ERROR)) {
resultObjPtr = Tcl_DuplicateObj (Tcl_GetObjResult (interp));
Tcl_IncrRefCount (resultObjPtr);
Tcl_ResetResult (interp);
code = GlobalImport (interp);
if (code != TCL_ERROR) {
if (Tcl_SetVar2Ex(interp, "errorResult", NULL,
resultObjPtr, TCL_LEAVE_ERR_MSG) == NULL) {
code = TCL_ERROR;
}
}
if (code != TCL_ERROR) {
code = Tcl_EvalObj (interp, objv [2]);
}
Tcl_DecrRefCount (resultObjPtr);
}
/*
* If a finally command is supplied, evaluate it, preserving the error
* status.
*/
if (haveFinally) {
savedResultsPtr = TclX_SaveResultErrorInfo (interp);
Tcl_ResetResult (interp);
code2 = Tcl_EvalObj (interp, objv [3]);
if (code2 == TCL_ERROR) {
Tcl_DecrRefCount (savedResultsPtr); /* Don't restore results */
code = code2;
} else {
TclX_RestoreResultErrorInfo (interp, savedResultsPtr);
}
}
return code;
}
/*-----------------------------------------------------------------------------
* TclX_GeneralInit --
* Initialize the command.
*-----------------------------------------------------------------------------
*/
void
TclX_GeneralInit (Tcl_Interp *interp)
{
Tcl_CreateObjCommand (interp,
"echo",
TclX_EchoObjCmd,
(ClientData) NULL,
(Tcl_CmdDeleteProc*) NULL);
Tcl_CreateObjCommand(interp,
"infox",
TclX_InfoxObjCmd,
(ClientData) NULL,
(Tcl_CmdDeleteProc*) NULL);
Tcl_CreateObjCommand(interp,
"loop",
TclX_LoopObjCmd,
(ClientData) NULL,
(Tcl_CmdDeleteProc*) NULL);
Tcl_CreateObjCommand(interp,
"try_eval",
TclX_Try_EvalObjCmd,
(ClientData) NULL,
(Tcl_CmdDeleteProc*) NULL);
}
/* vim: set ts=4 sw=4 sts=4 et : */