通讯编程

开发平台：

Visual C++

tclTest.c：源码内容

Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int i, ii, indices, stringLength, match, about;
int hasxflags, cflags, eflags;
Tcl_RegExp regExpr;
char *string;
Tcl_Obj *objPtr;
Tcl_RegExpInfo info;
static CONST char *options[] = {
"-indices", "-nocase", "-about", "-expanded",
"-line", "-linestop", "-lineanchor",
"-xflags",
"--", (char *) NULL
};
enum options {
REGEXP_INDICES, REGEXP_NOCASE, REGEXP_ABOUT, REGEXP_EXPANDED,
REGEXP_MULTI, REGEXP_NOCROSS, REGEXP_NEWL,
REGEXP_XFLAGS,
REGEXP_LAST
};
indices = 0;
about = 0;
cflags = REG_ADVANCED;
eflags = 0;
hasxflags = 0;
for (i = 1; i < objc; i++) {
char *name;
int index;
name = Tcl_GetString(objv[i]);
if (name[0] != '-') {
break;
}
if (Tcl_GetIndexFromObj(interp, objv[i], options, "switch", TCL_EXACT,
&index) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum options) index) {
case REGEXP_INDICES: {
indices = 1;
break;
}
case REGEXP_NOCASE: {
cflags |= REG_ICASE;
break;
}
case REGEXP_ABOUT: {
about = 1;
break;
}
case REGEXP_EXPANDED: {
cflags |= REG_EXPANDED;
break;
}
case REGEXP_MULTI: {
cflags |= REG_NEWLINE;
break;
}
case REGEXP_NOCROSS: {
cflags |= REG_NLSTOP;
break;
}
case REGEXP_NEWL: {
cflags |= REG_NLANCH;
break;
}
case REGEXP_XFLAGS: {
hasxflags = 1;
break;
}
case REGEXP_LAST: {
i++;
goto endOfForLoop;
}
}
}
endOfForLoop:
if (objc - i < hasxflags + 2 - about) {
Tcl_WrongNumArgs(interp, 1, objv,
"?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?");
return TCL_ERROR;
}
objc -= i;
objv += i;
if (hasxflags) {
string = Tcl_GetStringFromObj(objv[0], &stringLength);
TestregexpXflags(string, stringLength, &cflags, &eflags);
objc--;
objv++;
}
regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags);
if (regExpr == NULL) {
return TCL_ERROR;
}
objPtr = objv[1];
if (about) {
if (TclRegAbout(interp, regExpr) < 0) {
return TCL_ERROR;
}
return TCL_OK;
}
match = Tcl_RegExpExecObj(interp, regExpr, objPtr, 0 /* offset */,
objc-2 /* nmatches */, eflags);
if (match < 0) {
return TCL_ERROR;
}
if (match == 0) {
/*
* Set the interpreter's object result to an integer object w/
* value 0.
*/
Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
if (objc > 2 && (cflags&REG_EXPECT) && indices) {
char *varName;
CONST char *value;
int start, end;
char resinfo[TCL_INTEGER_SPACE * 2];
varName = Tcl_GetString(objv[2]);
TclRegExpRangeUniChar(regExpr, -1, &start, &end);
sprintf(resinfo, "%d %d", start, end-1);
value = Tcl_SetVar(interp, varName, resinfo, 0);
if (value == NULL) {
Tcl_AppendResult(interp, "couldn't set variable "",
varName, """, (char *) NULL);
return TCL_ERROR;
}
} else if (cflags & TCL_REG_CANMATCH) {
char *varName;
CONST char *value;
char resinfo[TCL_INTEGER_SPACE * 2];
Tcl_RegExpGetInfo(regExpr, &info);
varName = Tcl_GetString(objv[2]);
sprintf(resinfo, "%ld", info.extendStart);
value = Tcl_SetVar(interp, varName, resinfo, 0);
if (value == NULL) {
Tcl_AppendResult(interp, "couldn't set variable "",
varName, """, (char *) NULL);
return TCL_ERROR;
}
}
return TCL_OK;
}
/*
* If additional variable names have been specified, return
* index information in those variables.
*/
objc -= 2;
objv += 2;
Tcl_RegExpGetInfo(regExpr, &info);
for (i = 0; i < objc; i++) {
int start, end;
Tcl_Obj *newPtr, *varPtr, *valuePtr;
varPtr = objv[i];
ii = ((cflags&REG_EXPECT) && i == objc-1) ? -1 : i;
if (indices) {
Tcl_Obj *objs[2];
if (ii == -1) {
TclRegExpRangeUniChar(regExpr, ii, &start, &end);
} else if (ii > info.nsubs) {
start = -1;
end = -1;
} else {
start = info.matches[ii].start;
end = info.matches[ii].end;
}
/*
* Adjust index so it refers to the last character in the
* match instead of the first character after the match.
*/
if (end >= 0) {
end--;
}
objs[0] = Tcl_NewLongObj(start);
objs[1] = Tcl_NewLongObj(end);
newPtr = Tcl_NewListObj(2, objs);
} else {
if (ii == -1) {
TclRegExpRangeUniChar(regExpr, ii, &start, &end);
newPtr = Tcl_GetRange(objPtr, start, end);
} else if (ii > info.nsubs) {
newPtr = Tcl_NewObj();
} else {
newPtr = Tcl_GetRange(objPtr, info.matches[ii].start,
info.matches[ii].end - 1);
}
}
Tcl_IncrRefCount(newPtr);
valuePtr = Tcl_ObjSetVar2(interp, varPtr, NULL, newPtr, 0);
Tcl_DecrRefCount(newPtr);
if (valuePtr == NULL) {
Tcl_AppendResult(interp, "couldn't set variable "",
Tcl_GetString(varPtr), """, (char *) NULL);
return TCL_ERROR;
}
}
/*
* Set the interpreter's object result to an integer object w/ value 1.
*/
Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* TestregexpXflags --
*
* Parse a string of extended regexp flag letters, for testing.
*
* Results:
* No return value (you're on your own for errors here).
*
* Side effects:
* Modifies *cflagsPtr, a regcomp flags word, and *eflagsPtr, a
* regexec flags word, as appropriate.
*
*----------------------------------------------------------------------
*/
static void
TestregexpXflags(string, length, cflagsPtr, eflagsPtr)
char *string; /* The string of flags. */
int length; /* The length of the string in bytes. */
int *cflagsPtr; /* compile flags word */
int *eflagsPtr; /* exec flags word */
{
int i;
int cflags;
int eflags;
cflags = *cflagsPtr;
eflags = *eflagsPtr;
for (i = 0; i < length; i++) {
switch (string[i]) {
case 'a': {
cflags |= REG_ADVF;
break;
}
case 'b': {
cflags &= ~REG_ADVANCED;
break;
}
case 'c': {
cflags |= TCL_REG_CANMATCH;
break;
}
case 'e': {
cflags &= ~REG_ADVANCED;
cflags |= REG_EXTENDED;
break;
}
case 'q': {
cflags &= ~REG_ADVANCED;
cflags |= REG_QUOTE;
break;
}
case 'o': { /* o for opaque */
cflags |= REG_NOSUB;
break;
}
case 's': { /* s for start */
cflags |= REG_BOSONLY;
break;
}
case '+': {
cflags |= REG_FAKE;
break;
}
case ',': {
cflags |= REG_PROGRESS;
break;
}
case '.': {
cflags |= REG_DUMP;
break;
}
case ':': {
eflags |= REG_MTRACE;
break;
}
case ';': {
eflags |= REG_FTRACE;
break;
}
case '^': {
eflags |= REG_NOTBOL;
break;
}
case '$': {
eflags |= REG_NOTEOL;
break;
}
case 't': {
cflags |= REG_EXPECT;
break;
}
case '%': {
eflags |= REG_SMALL;
break;
}
}
}
*cflagsPtr = cflags;
*eflagsPtr = eflags;
}
/*
*----------------------------------------------------------------------
*
* TestsetassocdataCmd --
*
* This procedure implements the "testsetassocdata" command. It is used
* to test Tcl_SetAssocData.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Modifies or creates an association between a key and associated
* data for this interpreter.
*
*----------------------------------------------------------------------
*/
static int
TestsetassocdataCmd(clientData, interp, argc, argv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
char *buf;
char *oldData;
Tcl_InterpDeleteProc *procPtr;
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # arguments: should be "", argv[0],
" data_key data_item"", (char *) NULL);
return TCL_ERROR;
}
buf = ckalloc((unsigned) strlen(argv[2]) + 1);
strcpy(buf, argv[2]);
/*
* If we previously associated a malloced value with the variable,
* free it before associating a new value.
*/
oldData = (char *) Tcl_GetAssocData(interp, argv[1], &procPtr);
if ((oldData != NULL) && (procPtr == CleanupTestSetassocdataTests)) {
ckfree(oldData);
}
Tcl_SetAssocData(interp, argv[1], CleanupTestSetassocdataTests,
(ClientData) buf);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestsetplatformCmd --
*
* This procedure implements the "testsetplatform" command. It is
* used to change the tclPlatform global variable so all file
* name conversions can be tested on a single platform.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Sets the tclPlatform global variable.
*
*----------------------------------------------------------------------
*/
static int
TestsetplatformCmd(clientData, interp, argc, argv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
size_t length;
TclPlatformType *platform;
#ifdef __WIN32__
platform = TclWinGetPlatform();
#else
platform = &tclPlatform;
#endif
if (argc != 2) {
Tcl_AppendResult(interp, "wrong # arguments: should be "", argv[0],
" platform"", (char *) NULL);
return TCL_ERROR;
}
length = strlen(argv[1]);
if (strncmp(argv[1], "unix", length) == 0) {
*platform = TCL_PLATFORM_UNIX;
} else if (strncmp(argv[1], "mac", length) == 0) {
*platform = TCL_PLATFORM_MAC;
} else if (strncmp(argv[1], "windows", length) == 0) {
*platform = TCL_PLATFORM_WINDOWS;
} else {
Tcl_AppendResult(interp, "unsupported platform: should be one of ",
"unix, mac, or windows", (char *) NULL);
return TCL_ERROR;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TeststaticpkgCmd --
*
* This procedure implements the "teststaticpkg" command.
* It is used to test the procedure Tcl_StaticPackage.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* When the packge given by argv[1] is loaded into an interpeter,
* variable "x" in that interpreter is set to "loaded".
*
*----------------------------------------------------------------------
*/
static int
TeststaticpkgCmd(dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
int safe, loaded;
if (argc != 4) {
Tcl_AppendResult(interp, "wrong # arguments: should be "",
argv[0], " pkgName safe loaded"", (char *) NULL);
return TCL_ERROR;
}
if (Tcl_GetInt(interp, argv[2], &safe) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetInt(interp, argv[3], &loaded) != TCL_OK) {
return TCL_ERROR;
}
Tcl_StaticPackage((loaded) ? interp : NULL, argv[1], StaticInitProc,
(safe) ? StaticInitProc : NULL);
return TCL_OK;
}
static int
StaticInitProc(interp)
Tcl_Interp *interp; /* Interpreter in which package
* is supposedly being loaded. */
{
Tcl_SetVar(interp, "x", "loaded", TCL_GLOBAL_ONLY);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TesttranslatefilenameCmd --
*
* This procedure implements the "testtranslatefilename" command.
* It is used to test the Tcl_TranslateFileName command.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
TesttranslatefilenameCmd(dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
Tcl_DString buffer;
CONST char *result;
if (argc != 2) {
Tcl_AppendResult(interp, "wrong # arguments: should be "",
argv[0], " path"", (char *) NULL);
return TCL_ERROR;
}
result = Tcl_TranslateFileName(interp, argv[1], &buffer);
if (result == NULL) {
return TCL_ERROR;
}
Tcl_AppendResult(interp, result, NULL);
Tcl_DStringFree(&buffer);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestupvarCmd --
*
* This procedure implements the "testupvar2" command. It is used
* to test Tcl_UpVar and Tcl_UpVar2.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Creates or modifies an "upvar" reference.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
static int
TestupvarCmd(dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
int flags = 0;
if ((argc != 5) && (argc != 6)) {
Tcl_AppendResult(interp, "wrong # arguments: should be "",
argv[0], " level name ?name2? dest global"", (char *) NULL);
return TCL_ERROR;
}
if (argc == 5) {
if (strcmp(argv[4], "global") == 0) {
flags = TCL_GLOBAL_ONLY;
} else if (strcmp(argv[4], "namespace") == 0) {
flags = TCL_NAMESPACE_ONLY;
}
return Tcl_UpVar(interp, argv[1], argv[2], argv[3], flags);
} else {
if (strcmp(argv[5], "global") == 0) {
flags = TCL_GLOBAL_ONLY;
} else if (strcmp(argv[5], "namespace") == 0) {
flags = TCL_NAMESPACE_ONLY;
}
return Tcl_UpVar2(interp, argv[1], argv[2],
(argv[3][0] == 0) ? (char *) NULL : argv[3], argv[4],
flags);
}
}
/*
*----------------------------------------------------------------------
*
* TestseterrorcodeCmd --
*
* This procedure implements the "testseterrorcodeCmd".
* This tests up to five elements passed to the
* Tcl_SetErrorCode command.
*
* Results:
* A standard Tcl result. Always returns TCL_ERROR so that
* the error code can be tested.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
static int
TestseterrorcodeCmd(dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
if (argc > 6) {
Tcl_SetResult(interp, "too many args", TCL_STATIC);
return TCL_ERROR;
}
Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], argv[4],
argv[5], NULL);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* TestsetobjerrorcodeCmd --
*
* This procedure implements the "testsetobjerrorcodeCmd".
* This tests the Tcl_SetObjErrorCode function.
*
* Results:
* A standard Tcl result. Always returns TCL_ERROR so that
* the error code can be tested.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
static int
TestsetobjerrorcodeCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* The argument objects. */
{
Tcl_Obj *listObjPtr;
if (objc > 1) {
listObjPtr = Tcl_ConcatObj(objc - 1, objv + 1);
} else {
listObjPtr = Tcl_NewObj();
}
Tcl_IncrRefCount(listObjPtr);
Tcl_SetObjErrorCode(interp, listObjPtr);
Tcl_DecrRefCount(listObjPtr);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* TestfeventCmd --
*
* This procedure implements the "testfevent" command. It is
* used for testing the "fileevent" command.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Creates and deletes interpreters.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
static int
TestfeventCmd(clientData, interp, argc, argv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
static Tcl_Interp *interp2 = NULL;
int code;
Tcl_Channel chan;
if (argc < 2) {
Tcl_AppendResult(interp, "wrong # args: should be "", argv[0],
" option ?arg arg ...?", (char *) NULL);
return TCL_ERROR;
}
if (strcmp(argv[1], "cmd") == 0) {
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be "", argv[0],
" cmd script", (char *) NULL);
return TCL_ERROR;
}
if (interp2 != (Tcl_Interp *) NULL) {
code = Tcl_GlobalEval(interp2, argv[2]);
Tcl_SetObjResult(interp, Tcl_GetObjResult(interp2));
return code;
} else {
Tcl_AppendResult(interp,
"called "testfevent code" before "testfevent create"",
(char *) NULL);
return TCL_ERROR;
}
} else if (strcmp(argv[1], "create") == 0) {
if (interp2 != NULL) {
Tcl_DeleteInterp(interp2);
}
interp2 = Tcl_CreateInterp();
return Tcl_Init(interp2);
} else if (strcmp(argv[1], "delete") == 0) {
if (interp2 != NULL) {
Tcl_DeleteInterp(interp2);
}
interp2 = NULL;
} else if (strcmp(argv[1], "share") == 0) {
if (interp2 != NULL) {
chan = Tcl_GetChannel(interp, argv[2], NULL);
if (chan == (Tcl_Channel) NULL) {
return TCL_ERROR;
}
Tcl_RegisterChannel(interp2, chan);
}
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestpanicCmd --
*
* Calls the panic routine.
*
* Results:
* Always returns TCL_OK.
*
* Side effects:
* May exit application.
*
*----------------------------------------------------------------------
*/
static int
TestpanicCmd(dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
CONST char *argString;
/*
* Put the arguments into a var args structure
* Append all of the arguments together separated by spaces
*/
argString = Tcl_Merge(argc-1, argv+1);
panic(argString);
ckfree((char *)argString);
return TCL_OK;
}
static int
TestfileCmd(dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
Tcl_Obj *CONST argv[]; /* The argument objects. */
{
int force, i, j, result;
Tcl_Obj *error = NULL;
char *subcmd;
if (argc < 3) {
return TCL_ERROR;
}
force = 0;
i = 2;
if (strcmp(Tcl_GetString(argv[2]), "-force") == 0) {
force = 1;
i = 3;
}
if (argc - i > 2) {
return TCL_ERROR;
}
for (j = i; j < argc; j++) {
if (Tcl_FSGetNormalizedPath(interp, argv[j]) == NULL) {
return TCL_ERROR;
}
}
subcmd = Tcl_GetString(argv[1]);
if (strcmp(subcmd, "mv") == 0) {
result = TclpObjRenameFile(argv[i], argv[i + 1]);
} else if (strcmp(subcmd, "cp") == 0) {
result = TclpObjCopyFile(argv[i], argv[i + 1]);
} else if (strcmp(subcmd, "rm") == 0) {
result = TclpObjDeleteFile(argv[i]);
} else if (strcmp(subcmd, "mkdir") == 0) {
result = TclpObjCreateDirectory(argv[i]);
} else if (strcmp(subcmd, "cpdir") == 0) {
result = TclpObjCopyDirectory(argv[i], argv[i + 1], &error);
} else if (strcmp(subcmd, "rmdir") == 0) {
result = TclpObjRemoveDirectory(argv[i], force, &error);
} else {
result = TCL_ERROR;
goto end;
}
if (result != TCL_OK) {
if (error != NULL) {
if (Tcl_GetString(error)[0] != '') {
Tcl_AppendResult(interp, Tcl_GetString(error), " ", NULL);
}
Tcl_DecrRefCount(error);
}
Tcl_AppendResult(interp, Tcl_ErrnoId(), (char *) NULL);
}
end:
return result;
}
/*
*----------------------------------------------------------------------
*
* TestgetvarfullnameCmd --
*
* Implements the "testgetvarfullname" cmd that is used when testing
* the Tcl_GetVariableFullName procedure.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
TestgetvarfullnameCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* The argument objects. */
{
char *name, *arg;
int flags = 0;
Tcl_Namespace *namespacePtr;
Tcl_CallFrame frame;
Tcl_Var variable;
int result;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "name scope");
return TCL_ERROR;
}
name = Tcl_GetString(objv[1]);
arg = Tcl_GetString(objv[2]);
if (strcmp(arg, "global") == 0) {
flags = TCL_GLOBAL_ONLY;
} else if (strcmp(arg, "namespace") == 0) {
flags = TCL_NAMESPACE_ONLY;
}
/*
* This command, like any other created with Tcl_Create[Obj]Command,
* runs in the global namespace. As a "namespace-aware" command that
* needs to run in a particular namespace, it must activate that
* namespace itself.
*/
if (flags == TCL_NAMESPACE_ONLY) {
namespacePtr = Tcl_FindNamespace(interp, "::test_ns_var",
(Tcl_Namespace *) NULL, TCL_LEAVE_ERR_MSG);
if (namespacePtr == NULL) {
return TCL_ERROR;
}
result = Tcl_PushCallFrame(interp, &frame, namespacePtr,
/*isProcCallFrame*/ 0);
if (result != TCL_OK) {
return result;
}
}
variable = Tcl_FindNamespaceVar(interp, name, (Tcl_Namespace *) NULL,
(flags | TCL_LEAVE_ERR_MSG));
if (flags == TCL_NAMESPACE_ONLY) {
Tcl_PopCallFrame(interp);
}
if (variable == (Tcl_Var) NULL) {
return TCL_ERROR;
}
Tcl_GetVariableFullName(interp, variable, Tcl_GetObjResult(interp));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* GetTimesCmd --
*
* This procedure implements the "gettimes" command. It is
* used for computing the time needed for various basic operations
* such as reading variables, allocating memory, sprintf, converting
* variables, etc.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Allocates and frees memory, sets a variable "a" in the interpreter.
*
*----------------------------------------------------------------------
*/
static int
GetTimesCmd(unused, interp, argc, argv)
ClientData unused; /* Unused. */
Tcl_Interp *interp; /* The current interpreter. */
int argc; /* The number of arguments. */
CONST char **argv; /* The argument strings. */
{
Interp *iPtr = (Interp *) interp;
int i, n;
double timePer;
Tcl_Time start, stop;
Tcl_Obj *objPtr;
Tcl_Obj **objv;
CONST char *s;
char newString[TCL_INTEGER_SPACE];
/* alloc & free 100000 times */
fprintf(stderr, "alloc & free 100000 6 word itemsn");
Tcl_GetTime(&start);
for (i = 0; i < 100000; i++) {
objPtr = (Tcl_Obj *) ckalloc(sizeof(Tcl_Obj));
ckfree((char *) objPtr);
}
Tcl_GetTime(&stop);
timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
fprintf(stderr, " %.3f usec per alloc+freen", timePer/100000);
/* alloc 5000 times */
fprintf(stderr, "alloc 5000 6 word itemsn");
objv = (Tcl_Obj **) ckalloc(5000 * sizeof(Tcl_Obj *));
Tcl_GetTime(&start);
for (i = 0; i < 5000; i++) {
objv[i] = (Tcl_Obj *) ckalloc(sizeof(Tcl_Obj));
}
Tcl_GetTime(&stop);
timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
fprintf(stderr, " %.3f usec per allocn", timePer/5000);
/* free 5000 times */
fprintf(stderr, "free 5000 6 word itemsn");
Tcl_GetTime(&start);
for (i = 0; i < 5000; i++) {
ckfree((char *) objv[i]);
}
Tcl_GetTime(&stop);
timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
fprintf(stderr, " %.3f usec per freen", timePer/5000);
/* Tcl_NewObj 5000 times */
fprintf(stderr, "Tcl_NewObj 5000 timesn");
Tcl_GetTime(&start);
for (i = 0; i < 5000; i++) {
objv[i] = Tcl_NewObj();
}
Tcl_GetTime(&stop);
timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
fprintf(stderr, " %.3f usec per Tcl_NewObjn", timePer/5000);
/* Tcl_DecrRefCount 5000 times */
fprintf(stderr, "Tcl_DecrRefCount 5000 timesn");
Tcl_GetTime(&start);
for (i = 0; i < 5000; i++) {
objPtr = objv[i];
Tcl_DecrRefCount(objPtr);
}
Tcl_GetTime(&stop);
timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
fprintf(stderr, " %.3f usec per Tcl_DecrRefCountn", timePer/5000);
ckfree((char *) objv);
/* TclGetString 100000 times */
fprintf(stderr, "TclGetStringFromObj of "12345" 100000 timesn");
objPtr = Tcl_NewStringObj("12345", -1);
Tcl_GetTime(&start);
for (i = 0; i < 100000; i++) {
(void) TclGetString(objPtr);
}
Tcl_GetTime(&stop);
timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
fprintf(stderr, " %.3f usec per TclGetStringFromObj of "12345"n",
timePer/100000);
/* Tcl_GetIntFromObj 100000 times */
fprintf(stderr, "Tcl_GetIntFromObj of "12345" 100000 timesn");
Tcl_GetTime(&start);
for (i = 0; i < 100000; i++) {
if (Tcl_GetIntFromObj(interp, objPtr, &n) != TCL_OK) {
return TCL_ERROR;
}
}
Tcl_GetTime(&stop);
timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
fprintf(stderr, " %.3f usec per Tcl_GetIntFromObj of "12345"n",
timePer/100000);
Tcl_DecrRefCount(objPtr);
/* Tcl_GetInt 100000 times */
fprintf(stderr, "Tcl_GetInt of "12345" 100000 timesn");
Tcl_GetTime(&start);
for (i = 0; i < 100000; i++) {
if (Tcl_GetInt(interp, "12345", &n) != TCL_OK) {
return TCL_ERROR;
}
}
Tcl_GetTime(&stop);
timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
fprintf(stderr, " %.3f usec per Tcl_GetInt of "12345"n",
timePer/100000);
/* sprintf 100000 times */
fprintf(stderr, "sprintf of 12345 100000 timesn");
Tcl_GetTime(&start);
for (i = 0; i < 100000; i++) {
sprintf(newString, "%d", 12345);
}
Tcl_GetTime(&stop);
timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
fprintf(stderr, " %.3f usec per sprintf of 12345n",
timePer/100000);
/* hashtable lookup 100000 times */
fprintf(stderr, "hashtable lookup of "gettimes" 100000 timesn");
Tcl_GetTime(&start);
for (i = 0; i < 100000; i++) {
(void) Tcl_FindHashEntry(&iPtr->globalNsPtr->cmdTable, "gettimes");
}
Tcl_GetTime(&stop);
timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
fprintf(stderr, " %.3f usec per hashtable lookup of "gettimes"n",
timePer/100000);
/* Tcl_SetVar 100000 times */
fprintf(stderr, "Tcl_SetVar of "12345" 100000 timesn");
Tcl_GetTime(&start);
for (i = 0; i < 100000; i++) {
s = Tcl_SetVar(interp, "a", "12345", TCL_LEAVE_ERR_MSG);
if (s == NULL) {
return TCL_ERROR;
}
}
Tcl_GetTime(&stop);
timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
fprintf(stderr, " %.3f usec per Tcl_SetVar of a to "12345"n",
timePer/100000);
/* Tcl_GetVar 100000 times */
fprintf(stderr, "Tcl_GetVar of a=="12345" 100000 timesn");
Tcl_GetTime(&start);
for (i = 0; i < 100000; i++) {
s = Tcl_GetVar(interp, "a", TCL_LEAVE_ERR_MSG);
if (s == NULL) {
return TCL_ERROR;
}
}
Tcl_GetTime(&stop);
timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
fprintf(stderr, " %.3f usec per Tcl_GetVar of a=="12345"n",
timePer/100000);
Tcl_ResetResult(interp);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* NoopCmd --
*
* This procedure is just used to time the overhead involved in
* parsing and invoking a command.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
NoopCmd(unused, interp, argc, argv)
ClientData unused; /* Unused. */
Tcl_Interp *interp; /* The current interpreter. */
int argc; /* The number of arguments. */
CONST char **argv; /* The argument strings. */
{
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* NoopObjCmd --
*
* This object-based procedure is just used to time the overhead
* involved in parsing and invoking a command.
*
* Results:
* Returns the TCL_OK result code.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
NoopObjCmd(unused, interp, objc, objv)
ClientData unused; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* The argument objects. */
{
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestsetCmd --
*
* Implements the "testset{err,noerr}" cmds that are used when testing
* Tcl_Set/GetVar C Api with/without TCL_LEAVE_ERR_MSG flag
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Variables may be set.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
static int
TestsetCmd(data, interp, argc, argv)
ClientData data; /* Additional flags for Get/SetVar2. */
register Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
int flags = (int) data;
CONST char *value;
if (argc == 2) {
Tcl_SetResult(interp, "before get", TCL_STATIC);
value = Tcl_GetVar2(interp, argv[1], (char *) NULL, flags);
if (value == NULL) {
return TCL_ERROR;
}
Tcl_AppendElement(interp, value);
return TCL_OK;
} else if (argc == 3) {
Tcl_SetResult(interp, "before set", TCL_STATIC);
value = Tcl_SetVar2(interp, argv[1], (char *) NULL, argv[2], flags);
if (value == NULL) {
return TCL_ERROR;
}
Tcl_AppendElement(interp, value);
return TCL_OK;
} else {
Tcl_AppendResult(interp, "wrong # args: should be "",
argv[0], " varName ?newValue?"", (char *) NULL);
return TCL_ERROR;
}
}
/*
*----------------------------------------------------------------------
*
* TestsaveresultCmd --
*
* Implements the "testsaveresult" cmd that is used when testing
* the Tcl_SaveResult, Tcl_RestoreResult, and
* Tcl_DiscardResult interfaces.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
static int
TestsaveresultCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
register Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* The argument objects. */
{
int discard, result, index;
Tcl_SavedResult state;
Tcl_Obj *objPtr;
static CONST char *optionStrings[] = {
"append", "dynamic", "free", "object", "small", NULL
};
enum options {
RESULT_APPEND, RESULT_DYNAMIC, RESULT_FREE, RESULT_OBJECT, RESULT_SMALL
};
/*
* Parse arguments
*/
if (objc != 4) {
Tcl_WrongNumArgs(interp, 1, objv, "type script discard");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetBooleanFromObj(interp, objv[3], &discard) != TCL_OK) {
return TCL_ERROR;
}
objPtr = NULL; /* Lint. */
switch ((enum options) index) {
case RESULT_SMALL:
Tcl_SetResult(interp, "small result", TCL_VOLATILE);
break;
case RESULT_APPEND:
Tcl_AppendResult(interp, "append result", NULL);
break;
case RESULT_FREE: {
char *buf = ckalloc(200);
strcpy(buf, "free result");
Tcl_SetResult(interp, buf, TCL_DYNAMIC);
break;
}
case RESULT_DYNAMIC:
Tcl_SetResult(interp, "dynamic result", TestsaveresultFree);
break;
case RESULT_OBJECT:
objPtr = Tcl_NewStringObj("object result", -1);
Tcl_SetObjResult(interp, objPtr);
break;
}
freeCount = 0;
Tcl_SaveResult(interp, &state);
if (((enum options) index) == RESULT_OBJECT) {
result = Tcl_EvalObjEx(interp, objv[2], 0);
} else {
result = Tcl_Eval(interp, Tcl_GetString(objv[2]));
}
if (discard) {
Tcl_DiscardResult(&state);
} else {
Tcl_RestoreResult(interp, &state);
result = TCL_OK;
}
switch ((enum options) index) {
case RESULT_DYNAMIC: {
int present = interp->freeProc == TestsaveresultFree;
int called = freeCount;
Tcl_AppendElement(interp, called ? "called" : "notCalled");
Tcl_AppendElement(interp, present ? "present" : "missing");
break;
}
case RESULT_OBJECT:
Tcl_AppendElement(interp, Tcl_GetObjResult(interp) == objPtr
? "same" : "different");
break;
default:
break;
}
return result;
}
/*
*----------------------------------------------------------------------
*
* TestsaveresultFree --
*
* Special purpose freeProc used by TestsaveresultCmd.
*
* Results:
* None.
*
* Side effects:
* Increments the freeCount.
*
*----------------------------------------------------------------------
*/
static void
TestsaveresultFree(blockPtr)
char *blockPtr;
{
freeCount++;
}
/*
*----------------------------------------------------------------------
*
* TeststatprocCmd --
*
* Implements the "testTclStatProc" cmd that is used to test the
* 'TclStatInsertProc' & 'TclStatDeleteProc' C Apis.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
TeststatprocCmd (dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
register Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
TclStatProc_ *proc;
int retVal;
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be "",
argv[0], " option arg"", (char *) NULL);
return TCL_ERROR;
}
if (strcmp(argv[2], "TclpStat") == 0) {
proc = PretendTclpStat;
} else if (strcmp(argv[2], "TestStatProc1") == 0) {
proc = TestStatProc1;
} else if (strcmp(argv[2], "TestStatProc2") == 0) {
proc = TestStatProc2;
} else if (strcmp(argv[2], "TestStatProc3") == 0) {
proc = TestStatProc3;
} else {
Tcl_AppendResult(interp, "bad arg "", argv[1], "": ",
"must be TclpStat, ",
"TestStatProc1, TestStatProc2, or TestStatProc3",
(char *) NULL);
return TCL_ERROR;
}
if (strcmp(argv[1], "insert") == 0) {
if (proc == PretendTclpStat) {
Tcl_AppendResult(interp, "bad arg "", argv[1], "": ",
"must be ",
"TestStatProc1, TestStatProc2, or TestStatProc3",
(char *) NULL);
return TCL_ERROR;
}
retVal = TclStatInsertProc(proc);
} else if (strcmp(argv[1], "delete") == 0) {
retVal = TclStatDeleteProc(proc);
} else {
Tcl_AppendResult(interp, "bad option "", argv[1], "": ",
"must be insert or delete", (char *) NULL);
return TCL_ERROR;
}
if (retVal == TCL_ERROR) {
Tcl_AppendResult(interp, """, argv[2], "": ",
"could not be ", argv[1], "ed", (char *) NULL);
}
return retVal;
}
static int PretendTclpStat(path, buf)
CONST char *path;
struct stat *buf;
{
int ret;
Tcl_Obj *pathPtr = Tcl_NewStringObj(path, -1);
#ifdef TCL_WIDE_INT_IS_LONG
Tcl_IncrRefCount(pathPtr);
ret = TclpObjStat(pathPtr, buf);
Tcl_DecrRefCount(pathPtr);
return ret;
#else /* TCL_WIDE_INT_IS_LONG */
Tcl_StatBuf realBuf;
Tcl_IncrRefCount(pathPtr);
ret = TclpObjStat(pathPtr, &realBuf);
Tcl_DecrRefCount(pathPtr);
if (ret != -1) {
# define OUT_OF_RANGE(x)
(((Tcl_WideInt)(x)) < Tcl_LongAsWide(LONG_MIN) ||
((Tcl_WideInt)(x)) > Tcl_LongAsWide(LONG_MAX))
#if defined(__GNUC__) && __GNUC__ >= 2
/*
* Workaround gcc warning of "comparison is always false due to limited range of
* data type" in this macro by checking max type size, and when necessary ANDing
* with the complement of ULONG_MAX instead of the comparison:
*/
# define OUT_OF_URANGE(x)
((((Tcl_WideUInt)(~ (__typeof__(x)) 0)) > (Tcl_WideUInt)ULONG_MAX) &&
(((Tcl_WideUInt)(x)) & ~(Tcl_WideUInt)ULONG_MAX))
#else
# define OUT_OF_URANGE(x)
(((Tcl_WideUInt)(x)) > (Tcl_WideUInt)ULONG_MAX)
#endif
/*
* Perform the result-buffer overflow check manually.
*
* Note that ino_t/ino64_t is unsigned...
*/
if (OUT_OF_URANGE(realBuf.st_ino) || OUT_OF_RANGE(realBuf.st_size)
# ifdef HAVE_ST_BLOCKS
|| OUT_OF_RANGE(realBuf.st_blocks)
# endif
) {
# ifdef EOVERFLOW
errno = EOVERFLOW;
# else
# ifdef EFBIG
errno = EFBIG;
# else
# error "what error should be returned for a value out of range?"
# endif
# endif
return -1;
}
# undef OUT_OF_RANGE
# undef OUT_OF_URANGE
/*
* Copy across all supported fields, with possible type
* coercions on those fields that change between the normal
* and lf64 versions of the stat structure (on Solaris at
* least.) This is slow when the structure sizes coincide,
* but that's what you get for mixing interfaces...
*/
buf->st_mode = realBuf.st_mode;
buf->st_ino = (ino_t) realBuf.st_ino;
buf->st_dev = realBuf.st_dev;
buf->st_rdev = realBuf.st_rdev;
buf->st_nlink = realBuf.st_nlink;
buf->st_uid = realBuf.st_uid;
buf->st_gid = realBuf.st_gid;
buf->st_size = (off_t) realBuf.st_size;
buf->st_atime = realBuf.st_atime;
buf->st_mtime = realBuf.st_mtime;
buf->st_ctime = realBuf.st_ctime;
# ifdef HAVE_ST_BLOCKS
buf->st_blksize = realBuf.st_blksize;
buf->st_blocks = (blkcnt_t) realBuf.st_blocks;
# endif
}
return ret;
#endif /* TCL_WIDE_INT_IS_LONG */
}
/* Be careful in the compares in these tests, since the Macintosh puts a
* leading : in the beginning of non-absolute paths before passing them
* into the file command procedures.
*/
static int
TestStatProc1(path, buf)
CONST char *path;
struct stat *buf;
{
memset(buf, 0, sizeof(struct stat));
buf->st_size = 1234;
return ((strstr(path, "testStat1%.fil") == NULL) ? -1 : 0);
}
static int
TestStatProc2(path, buf)
CONST char *path;
struct stat *buf;
{
memset(buf, 0, sizeof(struct stat));
buf->st_size = 2345;
return ((strstr(path, "testStat2%.fil") == NULL) ? -1 : 0);
}
static int
TestStatProc3(path, buf)
CONST char *path;
struct stat *buf;
{
memset(buf, 0, sizeof(struct stat));
buf->st_size = 3456;
return ((strstr(path, "testStat3%.fil") == NULL) ? -1 : 0);
}
/*
*----------------------------------------------------------------------
*
* TestmainthreadCmd --
*
* Implements the "testmainthread" cmd that is used to test the
* 'Tcl_GetCurrentThread' API.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
TestmainthreadCmd (dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
register Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
if (argc == 1) {
Tcl_Obj *idObj = Tcl_NewLongObj((long)Tcl_GetCurrentThread());
Tcl_SetObjResult(interp, idObj);
return TCL_OK;
} else {
Tcl_SetResult(interp, "wrong # args", TCL_STATIC);
return TCL_ERROR;
}
}
/*
*----------------------------------------------------------------------
*
* MainLoop --
*
* A main loop set by TestsetmainloopCmd below.
*
* Results:
* None.
*
* Side effects:
* Event handlers could do anything.
*
*----------------------------------------------------------------------
*/
static void
MainLoop(void)
{
while (!exitMainLoop) {
Tcl_DoOneEvent(0);
}
fprintf(stdout,"Exit MainLoopn");
fflush(stdout);
}
/*
*----------------------------------------------------------------------
*
* TestsetmainloopCmd --
*
* Implements the "testsetmainloop" cmd that is used to test the
* 'Tcl_SetMainLoop' API.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
TestsetmainloopCmd (dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
register Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
exitMainLoop = 0;
Tcl_SetMainLoop(MainLoop);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestexitmainloopCmd --
*
* Implements the "testexitmainloop" cmd that is used to test the
* 'Tcl_SetMainLoop' API.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
TestexitmainloopCmd (dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
register Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
exitMainLoop = 1;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestaccessprocCmd --
*
* Implements the "testTclAccessProc" cmd that is used to test the
* 'TclAccessInsertProc' & 'TclAccessDeleteProc' C Apis.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
TestaccessprocCmd (dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
register Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
TclAccessProc_ *proc;
int retVal;
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be "",
argv[0], " option arg"", (char *) NULL);
return TCL_ERROR;
}
if (strcmp(argv[2], "TclpAccess") == 0) {
proc = PretendTclpAccess;
} else if (strcmp(argv[2], "TestAccessProc1") == 0) {
proc = TestAccessProc1;
} else if (strcmp(argv[2], "TestAccessProc2") == 0) {
proc = TestAccessProc2;
} else if (strcmp(argv[2], "TestAccessProc3") == 0) {
proc = TestAccessProc3;
} else {
Tcl_AppendResult(interp, "bad arg "", argv[1], "": ",
"must be TclpAccess, ",
"TestAccessProc1, TestAccessProc2, or TestAccessProc3",
(char *) NULL);
return TCL_ERROR;
}
if (strcmp(argv[1], "insert") == 0) {
if (proc == PretendTclpAccess) {
Tcl_AppendResult(interp, "bad arg "", argv[1], "": ",
"must be ",
"TestAccessProc1, TestAccessProc2, or TestAccessProc3",
(char *) NULL);
return TCL_ERROR;
}
retVal = TclAccessInsertProc(proc);
} else if (strcmp(argv[1], "delete") == 0) {
retVal = TclAccessDeleteProc(proc);
} else {
Tcl_AppendResult(interp, "bad option "", argv[1], "": ",
"must be insert or delete", (char *) NULL);
return TCL_ERROR;
}
if (retVal == TCL_ERROR) {
Tcl_AppendResult(interp, """, argv[2], "": ",
"could not be ", argv[1], "ed", (char *) NULL);
}
return retVal;
}
static int PretendTclpAccess(path, mode)
CONST char *path;
int mode;
{
int ret;
Tcl_Obj *pathPtr = Tcl_NewStringObj(path, -1);
Tcl_IncrRefCount(pathPtr);
ret = TclpObjAccess(pathPtr, mode);
Tcl_DecrRefCount(pathPtr);
return ret;
}
static int
TestAccessProc1(path, mode)
CONST char *path;
int mode;
{
return ((strstr(path, "testAccess1%.fil") == NULL) ? -1 : 0);
}
static int
TestAccessProc2(path, mode)
CONST char *path;
int mode;
{
return ((strstr(path, "testAccess2%.fil") == NULL) ? -1 : 0);
}
static int
TestAccessProc3(path, mode)
CONST char *path;
int mode;
{
return ((strstr(path, "testAccess3%.fil") == NULL) ? -1 : 0);
}
/*
*----------------------------------------------------------------------
*
* TestopenfilechannelprocCmd --
*
* Implements the "testTclOpenFileChannelProc" cmd that is used to test the
* 'TclOpenFileChannelInsertProc' & 'TclOpenFileChannelDeleteProc' C Apis.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
TestopenfilechannelprocCmd (dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
register Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
TclOpenFileChannelProc_ *proc;
int retVal;
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be "",
argv[0], " option arg"", (char *) NULL);
return TCL_ERROR;
}
if (strcmp(argv[2], "TclpOpenFileChannel") == 0) {
proc = PretendTclpOpenFileChannel;
} else if (strcmp(argv[2], "TestOpenFileChannelProc1") == 0) {
proc = TestOpenFileChannelProc1;
} else if (strcmp(argv[2], "TestOpenFileChannelProc2") == 0) {
proc = TestOpenFileChannelProc2;
} else if (strcmp(argv[2], "TestOpenFileChannelProc3") == 0) {
proc = TestOpenFileChannelProc3;
} else {
Tcl_AppendResult(interp, "bad arg "", argv[1], "": ",
"must be TclpOpenFileChannel, ",
"TestOpenFileChannelProc1, TestOpenFileChannelProc2, or ",
"TestOpenFileChannelProc3",
(char *) NULL);
return TCL_ERROR;
}
if (strcmp(argv[1], "insert") == 0) {
if (proc == PretendTclpOpenFileChannel) {
Tcl_AppendResult(interp, "bad arg "", argv[1], "": ",
"must be ",
"TestOpenFileChannelProc1, TestOpenFileChannelProc2, or ",
"TestOpenFileChannelProc3",
(char *) NULL);
return TCL_ERROR;
}
retVal = TclOpenFileChannelInsertProc(proc);
} else if (strcmp(argv[1], "delete") == 0) {
retVal = TclOpenFileChannelDeleteProc(proc);
} else {
Tcl_AppendResult(interp, "bad option "", argv[1], "": ",
"must be insert or delete", (char *) NULL);
return TCL_ERROR;
}
if (retVal == TCL_ERROR) {
Tcl_AppendResult(interp, """, argv[2], "": ",
"could not be ", argv[1], "ed", (char *) NULL);
}
return retVal;
}
static Tcl_Channel
PretendTclpOpenFileChannel(interp, fileName, modeString, permissions)
Tcl_Interp *interp; /* Interpreter for error reporting;
* can be NULL. */
CONST char *fileName; /* Name of file to open. */
CONST char *modeString; /* A list of POSIX open modes or
* a string such as "rw". */
int permissions; /* If the open involves creating a
* file, with what modes to create
* it? */
{
Tcl_Channel ret;
int mode, seekFlag;
Tcl_Obj *pathPtr;
mode = TclGetOpenMode(interp, modeString, &seekFlag);
if (mode == -1) {
return NULL;
}
pathPtr = Tcl_NewStringObj(fileName, -1);
Tcl_IncrRefCount(pathPtr);
ret = TclpOpenFileChannel(interp, pathPtr, mode, permissions);
Tcl_DecrRefCount(pathPtr);
if (ret != NULL) {
if (seekFlag) {
if (Tcl_Seek(ret, (Tcl_WideInt)0, SEEK_END) < (Tcl_WideInt)0) {
if (interp != (Tcl_Interp *) NULL) {
Tcl_AppendResult(interp,
"could not seek to end of file while opening "",
fileName, "": ",
Tcl_PosixError(interp), (char *) NULL);
}
Tcl_Close(NULL, ret);
return NULL;
}
}
}
return ret;
}
static Tcl_Channel
TestOpenFileChannelProc1(interp, fileName, modeString, permissions)
Tcl_Interp *interp; /* Interpreter for error reporting;
* can be NULL. */
CONST char *fileName; /* Name of file to open. */
CONST char *modeString; /* A list of POSIX open modes or
* a string such as "rw". */
int permissions; /* If the open involves creating a
* file, with what modes to create
* it? */
{
CONST char *expectname="testOpenFileChannel1%.fil";
Tcl_DString ds;
Tcl_DStringInit(&ds);
Tcl_JoinPath(1, &expectname, &ds);
if (!strcmp(Tcl_DStringValue(&ds), fileName)) {
Tcl_DStringFree(&ds);
return (PretendTclpOpenFileChannel(interp, "__testOpenFileChannel1%__.fil",
modeString, permissions));
} else {
Tcl_DStringFree(&ds);
return (NULL);
}
}
static Tcl_Channel
TestOpenFileChannelProc2(interp, fileName, modeString, permissions)
Tcl_Interp *interp; /* Interpreter for error reporting;
* can be NULL. */
CONST char *fileName; /* Name of file to open. */
CONST char *modeString; /* A list of POSIX open modes or
* a string such as "rw". */
int permissions; /* If the open involves creating a
* file, with what modes to create
* it? */
{
CONST char *expectname="testOpenFileChannel2%.fil";
Tcl_DString ds;
Tcl_DStringInit(&ds);
Tcl_JoinPath(1, &expectname, &ds);
if (!strcmp(Tcl_DStringValue(&ds), fileName)) {
Tcl_DStringFree(&ds);
return (PretendTclpOpenFileChannel(interp, "__testOpenFileChannel2%__.fil",
modeString, permissions));
} else {
Tcl_DStringFree(&ds);
return (NULL);
}
}
static Tcl_Channel
TestOpenFileChannelProc3(interp, fileName, modeString, permissions)
Tcl_Interp *interp; /* Interpreter for error reporting;
* can be NULL. */
CONST char *fileName; /* Name of file to open. */
CONST char *modeString; /* A list of POSIX open modes or
* a string such as "rw". */
int permissions; /* If the open involves creating a
* file, with what modes to create
* it? */
{
CONST char *expectname="testOpenFileChannel3%.fil";
Tcl_DString ds;
Tcl_DStringInit(&ds);
Tcl_JoinPath(1, &expectname, &ds);
if (!strcmp(Tcl_DStringValue(&ds), fileName)) {
Tcl_DStringFree(&ds);
return (PretendTclpOpenFileChannel(interp, "__testOpenFileChannel3%__.fil",
modeString, permissions));
} else {
Tcl_DStringFree(&ds);
return (NULL);
}
}
/*
*----------------------------------------------------------------------
*
* TestChannelCmd --
*
* Implements the Tcl "testchannel" debugging command and its
* subcommands. This is part of the testing environment.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
static int
TestChannelCmd(clientData, interp, argc, argv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Interpreter for result. */
int argc; /* Count of additional args. */
CONST char **argv; /* Additional arg strings. */
{
CONST char *cmdName; /* Sub command. */
Tcl_HashTable *hTblPtr; /* Hash table of channels. */
Tcl_HashSearch hSearch; /* Search variable. */
Tcl_HashEntry *hPtr; /* Search variable. */
Channel *chanPtr; /* The actual channel. */
ChannelState *statePtr; /* state info for channel */
Tcl_Channel chan; /* The opaque type. */
size_t len; /* Length of subcommand string. */
int IOQueued; /* How much IO is queued inside channel? */
ChannelBuffer *bufPtr; /* For iterating over queued IO. */
char buf[TCL_INTEGER_SPACE];/* For sprintf. */
int mode; /* rw mode of the channel */
if (argc < 2) {
Tcl_AppendResult(interp, "wrong # args: should be "", argv[0],
" subcommand ?additional args..?"", (char *) NULL);
return TCL_ERROR;
}
cmdName = argv[1];
len = strlen(cmdName);
chanPtr = (Channel *) NULL;
if (argc > 2) {
chan = Tcl_GetChannel(interp, argv[2], &mode);
if (chan == (Tcl_Channel) NULL) {
return TCL_ERROR;
}
chanPtr = (Channel *) chan;
statePtr = chanPtr->state;
chanPtr = statePtr->topChanPtr;
chan = (Tcl_Channel) chanPtr;
} else {
/* lint */
statePtr = NULL;
chan = NULL;
}
if ((cmdName[0] == 'c') && (strncmp(cmdName, "cut", len) == 0)) {
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be "", argv[0],
" cut channelName"", (char *) NULL);
return TCL_ERROR;
}
Tcl_CutChannel(chan);
return TCL_OK;
}
if ((cmdName[0] == 'c') &&
(strncmp(cmdName, "clearchannelhandlers", len) == 0)) {
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be "", argv[0],
" clearchannelhandlers channelName"", (char *) NULL);
return TCL_ERROR;
}
Tcl_ClearChannelHandlers(chan);
return TCL_OK;
}
if ((cmdName[0] == 'i') && (strncmp(cmdName, "info", len) == 0)) {
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be "", argv[0],
" info channelName"", (char *) NULL);
return TCL_ERROR;
}
Tcl_AppendElement(interp, argv[2]);
Tcl_AppendElement(interp, Tcl_ChannelName(chanPtr->typePtr));
if (statePtr->flags & TCL_READABLE) {
Tcl_AppendElement(interp, "read");
} else {
Tcl_AppendElement(interp, "");
}
if (statePtr->flags & TCL_WRITABLE) {
Tcl_AppendElement(interp, "write");
} else {
Tcl_AppendElement(interp, "");
}
if (statePtr->flags & CHANNEL_NONBLOCKING) {
Tcl_AppendElement(interp, "nonblocking");
} else {
Tcl_AppendElement(interp, "blocking");
}
if (statePtr->flags & CHANNEL_LINEBUFFERED) {
Tcl_AppendElement(interp, "line");
} else if (statePtr->flags & CHANNEL_UNBUFFERED) {
Tcl_AppendElement(interp, "none");
} else {
Tcl_AppendElement(interp, "full");
}
if (statePtr->flags & BG_FLUSH_SCHEDULED) {
Tcl_AppendElement(interp, "async_flush");
} else {
Tcl_AppendElement(interp, "");
}
if (statePtr->flags & CHANNEL_EOF) {
Tcl_AppendElement(interp, "eof");
} else {
Tcl_AppendElement(interp, "");
}
if (statePtr->flags & CHANNEL_BLOCKED) {
Tcl_AppendElement(interp, "blocked");
} else {
Tcl_AppendElement(interp, "unblocked");
}
if (statePtr->inputTranslation == TCL_TRANSLATE_AUTO) {
Tcl_AppendElement(interp, "auto");
if (statePtr->flags & INPUT_SAW_CR) {
Tcl_AppendElement(interp, "saw_cr");
} else {
Tcl_AppendElement(interp, "");
}
} else if (statePtr->inputTranslation == TCL_TRANSLATE_LF) {
Tcl_AppendElement(interp, "lf");
Tcl_AppendElement(interp, "");
} else if (statePtr->inputTranslation == TCL_TRANSLATE_CR) {
Tcl_AppendElement(interp, "cr");
Tcl_AppendElement(interp, "");
} else if (statePtr->inputTranslation == TCL_TRANSLATE_CRLF) {
Tcl_AppendElement(interp, "crlf");
if (statePtr->flags & INPUT_SAW_CR) {
Tcl_AppendElement(interp, "queued_cr");
} else {
Tcl_AppendElement(interp, "");
}
}
if (statePtr->outputTranslation == TCL_TRANSLATE_AUTO) {
Tcl_AppendElement(interp, "auto");
} else if (statePtr->outputTranslation == TCL_TRANSLATE_LF) {
Tcl_AppendElement(interp, "lf");
} else if (statePtr->outputTranslation == TCL_TRANSLATE_CR) {
Tcl_AppendElement(interp, "cr");
} else if (statePtr->outputTranslation == TCL_TRANSLATE_CRLF) {
Tcl_AppendElement(interp, "crlf");
}
for (IOQueued = 0, bufPtr = statePtr->inQueueHead;
bufPtr != (ChannelBuffer *) NULL;
bufPtr = bufPtr->nextPtr) {
IOQueued += bufPtr->nextAdded - bufPtr->nextRemoved;
}
TclFormatInt(buf, IOQueued);
Tcl_AppendElement(interp, buf);
IOQueued = 0;
if (statePtr->curOutPtr != (ChannelBuffer *) NULL) {
IOQueued = statePtr->curOutPtr->nextAdded -
statePtr->curOutPtr->nextRemoved;
}
for (bufPtr = statePtr->outQueueHead;
bufPtr != (ChannelBuffer *) NULL;
bufPtr = bufPtr->nextPtr) {
IOQueued += (bufPtr->nextAdded - bufPtr->nextRemoved);
}
TclFormatInt(buf, IOQueued);
Tcl_AppendElement(interp, buf);
TclFormatInt(buf, (int)Tcl_Tell((Tcl_Channel) chanPtr));
Tcl_AppendElement(interp, buf);
TclFormatInt(buf, statePtr->refCount);
Tcl_AppendElement(interp, buf);
return TCL_OK;
}
if ((cmdName[0] == 'i') &&
(strncmp(cmdName, "inputbuffered", len) == 0)) {
if (argc != 3) {
Tcl_AppendResult(interp, "channel name required",
(char *) NULL);
return TCL_ERROR;
}
for (IOQueued = 0, bufPtr = statePtr->inQueueHead;
bufPtr != (ChannelBuffer *) NULL;
bufPtr = bufPtr->nextPtr) {
IOQueued += bufPtr->nextAdded - bufPtr->nextRemoved;
}
TclFormatInt(buf, IOQueued);
Tcl_AppendResult(interp, buf, (char *) NULL);
return TCL_OK;
}
if ((cmdName[0] == 'i') && (strncmp(cmdName, "isshared", len) == 0)) {
if (argc != 3) {
Tcl_AppendResult(interp, "channel name required", (char *) NULL);
return TCL_ERROR;
}
TclFormatInt(buf, Tcl_IsChannelShared(chan));
Tcl_AppendResult(interp, buf, (char *) NULL);
return TCL_OK;
}
if ((cmdName[0] == 'i') && (strncmp(cmdName, "isstandard", len) == 0)) {
if (argc != 3) {
Tcl_AppendResult(interp, "channel name required", (char *) NULL);
return TCL_ERROR;
}
TclFormatInt(buf, Tcl_IsStandardChannel(chan));
Tcl_AppendResult(interp, buf, (char *) NULL);
return TCL_OK;
}
if ((cmdName[0] == 'm') && (strncmp(cmdName, "mode", len) == 0)) {
if (argc != 3) {
Tcl_AppendResult(interp, "channel name required",
(char *) NULL);
return TCL_ERROR;
}
if (statePtr->flags & TCL_READABLE) {
Tcl_AppendElement(interp, "read");
} else {
Tcl_AppendElement(interp, "");
}
if (statePtr->flags & TCL_WRITABLE) {
Tcl_AppendElement(interp, "write");
} else {
Tcl_AppendElement(interp, "");
}
return TCL_OK;
}
if ((cmdName[0] == 'm') && (strncmp(cmdName, "mthread", len) == 0)) {
if (argc != 3) {
Tcl_AppendResult(interp, "channel name required",
(char *) NULL);
return TCL_ERROR;
}
TclFormatInt(buf, (long) Tcl_GetChannelThread(chan));
Tcl_AppendResult(interp, buf, (char *) NULL);
return TCL_OK;
}
if ((cmdName[0] == 'n') && (strncmp(cmdName, "name", len) == 0)) {
if (argc != 3) {
Tcl_AppendResult(interp, "channel name required",
(char *) NULL);
return TCL_ERROR;
}
Tcl_AppendResult(interp, statePtr->channelName, (char *) NULL);
return TCL_OK;
}
if ((cmdName[0] == 'o') && (strncmp(cmdName, "open", len) == 0)) {
hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL);
if (hTblPtr == (Tcl_HashTable *) NULL) {
return TCL_OK;
}
for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch);
hPtr != (Tcl_HashEntry *) NULL;
hPtr = Tcl_NextHashEntry(&hSearch)) {
Tcl_AppendElement(interp, Tcl_GetHashKey(hTblPtr, hPtr));
}
return TCL_OK;
}
if ((cmdName[0] == 'o') &&
(strncmp(cmdName, "outputbuffered", len) == 0)) {
if (argc != 3) {
Tcl_AppendResult(interp, "channel name required",
(char *) NULL);
return TCL_ERROR;
}
IOQueued = 0;
if (statePtr->curOutPtr != (ChannelBuffer *) NULL) {
IOQueued = statePtr->curOutPtr->nextAdded -
statePtr->curOutPtr->nextRemoved;
}
for (bufPtr = statePtr->outQueueHead;
bufPtr != (ChannelBuffer *) NULL;
bufPtr = bufPtr->nextPtr) {
IOQueued += (bufPtr->nextAdded - bufPtr->nextRemoved);
}
TclFormatInt(buf, IOQueued);
Tcl_AppendResult(interp, buf, (char *) NULL);
return TCL_OK;
}
if ((cmdName[0] == 'q') &&
(strncmp(cmdName, "queuedcr", len) == 0)) {
if (argc != 3) {
Tcl_AppendResult(interp, "channel name required",
(char *) NULL);
return TCL_ERROR;
}
Tcl_AppendResult(interp,
(statePtr->flags & INPUT_SAW_CR) ? "1" : "0",
(char *) NULL);
return TCL_OK;
}
if ((cmdName[0] == 'r') && (strncmp(cmdName, "readable", len) == 0)) {
hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL);
if (hTblPtr == (Tcl_HashTable *) NULL) {
return TCL_OK;
}
for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch);
hPtr != (Tcl_HashEntry *) NULL;
hPtr = Tcl_NextHashEntry(&hSearch)) {
chanPtr = (Channel *) Tcl_GetHashValue(hPtr);
statePtr = chanPtr->state;
if (statePtr->flags & TCL_READABLE) {
Tcl_AppendElement(interp, Tcl_GetHashKey(hTblPtr, hPtr));
}
}
return TCL_OK;
}
if ((cmdName[0] == 'r') && (strncmp(cmdName, "refcount", len) == 0)) {
if (argc != 3) {
Tcl_AppendResult(interp, "channel name required",
(char *) NULL);
return TCL_ERROR;
}
TclFormatInt(buf, statePtr->refCount);
Tcl_AppendResult(interp, buf, (char *) NULL);
return TCL_OK;
}
if ((cmdName[0] == 's') && (strncmp(cmdName, "splice", len) == 0)) {
if (argc != 3) {
Tcl_AppendResult(interp, "channel name required", (char *) NULL);
return TCL_ERROR;
}
Tcl_SpliceChannel(chan);
return TCL_OK;
}
if ((cmdName[0] == 't') && (strncmp(cmdName, "type", len) == 0)) {
if (argc != 3) {
Tcl_AppendResult(interp, "channel name required",
(char *) NULL);
return TCL_ERROR;
}
Tcl_AppendResult(interp, Tcl_ChannelName(chanPtr->typePtr),
(char *) NULL);
return TCL_OK;
}
if ((cmdName[0] == 'w') && (strncmp(cmdName, "writable", len) == 0)) {
hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL);
if (hTblPtr == (Tcl_HashTable *) NULL) {
return TCL_OK;
}
for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch);
hPtr != (Tcl_HashEntry *) NULL;
hPtr = Tcl_NextHashEntry(&hSearch)) {
chanPtr = (Channel *) Tcl_GetHashValue(hPtr);
statePtr = chanPtr->state;
if (statePtr->flags & TCL_WRITABLE) {
Tcl_AppendElement(interp, Tcl_GetHashKey(hTblPtr, hPtr));
}
}
return TCL_OK;
}
if ((cmdName[0] == 't') && (strncmp(cmdName, "transform", len) == 0)) {
/*
* Syntax: transform channel -command command
*/
if (argc != 5) {
Tcl_AppendResult(interp, "wrong # args: should be "", argv[0],
" transform channelId -command cmd"", (char *) NULL);
return TCL_ERROR;
}
if (strcmp(argv[3], "-command") != 0) {
Tcl_AppendResult(interp, "bad argument "", argv[3],
"": should be "-command"", (char *) NULL);
return TCL_ERROR;
}
return TclChannelTransform(interp, chan,
Tcl_NewStringObj(argv[4], -1));
}
if ((cmdName[0] == 'u') && (strncmp(cmdName, "unstack", len) == 0)) {
/*
* Syntax: unstack channel
*/
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be "", argv[0],
" unstack channel"", (char *) NULL);
return TCL_ERROR;
}
return Tcl_UnstackChannel(interp, chan);
}
Tcl_AppendResult(interp, "bad option "", cmdName, "": should be ",
"cut, clearchannelhandlers, info, isshared, mode, open, "
"readable, splice, writable, transform, unstack",
(char *) NULL);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* TestChannelEventCmd --
*
* This procedure implements the "testchannelevent" command. It is
* used to test the Tcl channel event mechanism.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Creates, deletes and returns channel event handlers.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
static int
TestChannelEventCmd(dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
Tcl_Obj *resultListPtr;
Channel *chanPtr;
ChannelState *statePtr; /* state info for channel */
EventScriptRecord *esPtr, *prevEsPtr, *nextEsPtr;
CONST char *cmd;
int index, i, mask, len;
if ((argc < 3) || (argc > 5)) {
Tcl_AppendResult(interp, "wrong # args: should be "", argv[0],
" channelName cmd ?arg1? ?arg2?"", (char *) NULL);
return TCL_ERROR;
}
chanPtr = (Channel *) Tcl_GetChannel(interp, argv[1], NULL);
if (chanPtr == (Channel *) NULL) {
return TCL_ERROR;
}
statePtr = chanPtr->state;
cmd = argv[2];
len = strlen(cmd);
if ((cmd[0] == 'a') && (strncmp(cmd, "add", (unsigned) len) == 0)) {
if (argc != 5) {
Tcl_AppendResult(interp, "wrong # args: should be "", argv[0],
" channelName add eventSpec script"", (char *) NULL);
return TCL_ERROR;
}
if (strcmp(argv[3], "readable") == 0) {
mask = TCL_READABLE;
} else if (strcmp(argv[3], "writable") == 0) {
mask = TCL_WRITABLE;
} else if (strcmp(argv[3], "none") == 0) {
mask = 0;
} else {
Tcl_AppendResult(interp, "bad event name "", argv[3],
"": must be readable, writable, or none", (char *) NULL);
return TCL_ERROR;
}
esPtr = (EventScriptRecord *) ckalloc((unsigned)
sizeof(EventScriptRecord));
esPtr->nextPtr = statePtr->scriptRecordPtr;
statePtr->scriptRecordPtr = esPtr;
esPtr->chanPtr = chanPtr;
esPtr->interp = interp;
esPtr->mask = mask;
esPtr->scriptPtr = Tcl_NewStringObj(argv[4], -1);
Tcl_IncrRefCount(esPtr->scriptPtr);
Tcl_CreateChannelHandler((Tcl_Channel) chanPtr, mask,
TclChannelEventScriptInvoker, (ClientData) esPtr);
return TCL_OK;
}
if ((cmd[0] == 'd') && (strncmp(cmd, "delete", (unsigned) len) == 0)) {
if (argc != 4) {
Tcl_AppendResult(interp, "wrong # args: should be "", argv[0],
" channelName delete index"", (char *) NULL);
return TCL_ERROR;
}
if (Tcl_GetInt(interp, argv[3], &index) == TCL_ERROR) {
return TCL_ERROR;
}
if (index < 0) {
Tcl_AppendResult(interp, "bad event index: ", argv[3],
": must be nonnegative", (char *) NULL);
return TCL_ERROR;
}
for (i = 0, esPtr = statePtr->scriptRecordPtr;
(i < index) && (esPtr != (EventScriptRecord *) NULL);
i++, esPtr = esPtr->nextPtr) {
/* Empty loop body. */
}
if (esPtr == (EventScriptRecord *) NULL) {
Tcl_AppendResult(interp, "bad event index ", argv[3],
": out of range", (char *) NULL);
return TCL_ERROR;
}
if (esPtr == statePtr->scriptRecordPtr) {
statePtr->scriptRecordPtr = esPtr->nextPtr;
} else {
for (prevEsPtr = statePtr->scriptRecordPtr;
(prevEsPtr != (EventScriptRecord *) NULL) &&
(prevEsPtr->nextPtr != esPtr);
prevEsPtr = prevEsPtr->nextPtr) {
/* Empty loop body. */
}
if (prevEsPtr == (EventScriptRecord *) NULL) {
panic("TestChannelEventCmd: damaged event script list");
}
prevEsPtr->nextPtr = esPtr->nextPtr;
}
Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr,
TclChannelEventScriptInvoker, (ClientData) esPtr);
Tcl_DecrRefCount(esPtr->scriptPtr);
ckfree((char *) esPtr);
return TCL_OK;
}
if ((cmd[0] == 'l') && (strncmp(cmd, "list", (unsigned) len) == 0)) {
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be "", argv[0],
" channelName list"", (char *) NULL);
return TCL_ERROR;
}
resultListPtr = Tcl_GetObjResult(interp);
for (esPtr = statePtr->scriptRecordPtr;
esPtr != (EventScriptRecord *) NULL;
esPtr = esPtr->nextPtr) {
if (esPtr->mask) {
Tcl_ListObjAppendElement(interp, resultListPtr, Tcl_NewStringObj(
(esPtr->mask == TCL_READABLE) ? "readable" : "writable", -1));
} else {
Tcl_ListObjAppendElement(interp, resultListPtr,
Tcl_NewStringObj("none", -1));
}
Tcl_ListObjAppendElement(interp, resultListPtr, esPtr->scriptPtr);
}
Tcl_SetObjResult(interp, resultListPtr);
return TCL_OK;
}
if ((cmd[0] == 'r') && (strncmp(cmd, "removeall", (unsigned) len) == 0)) {
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be "", argv[0],
" channelName removeall"", (char *) NULL);
return TCL_ERROR;
}
for (esPtr = statePtr->scriptRecordPtr;
esPtr != (EventScriptRecord *) NULL;
esPtr = nextEsPtr) {
nextEsPtr = esPtr->nextPtr;
Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr,
TclChannelEventScriptInvoker, (ClientData) esPtr);
Tcl_DecrRefCount(esPtr->scriptPtr);
ckfree((char *) esPtr);
}
statePtr->scriptRecordPtr = (EventScriptRecord *) NULL;
return TCL_OK;
}
if ((cmd[0] == 's') && (strncmp(cmd, "set", (unsigned) len) == 0)) {
if (argc != 5) {
Tcl_AppendResult(interp, "wrong # args: should be "", argv[0],
" channelName delete index event"", (char *) NULL);
return TCL_ERROR;
}
if (Tcl_GetInt(interp, argv[3], &index) == TCL_ERROR) {
return TCL_ERROR;
}
if (index < 0) {
Tcl_AppendResult(interp, "bad event index: ", argv[3],
": must be nonnegative", (char *) NULL);
return TCL_ERROR;
}
for (i = 0, esPtr = statePtr->scriptRecordPtr;
(i < index) && (esPtr != (EventScriptRecord *) NULL);
i++, esPtr = esPtr->nextPtr) {
/* Empty loop body. */
}
if (esPtr == (EventScriptRecord *) NULL) {
Tcl_AppendResult(interp, "bad event index ", argv[3],
": out of range", (char *) NULL);
return TCL_ERROR;
}
if (strcmp(argv[4], "readable") == 0) {
mask = TCL_READABLE;
} else if (strcmp(argv[4], "writable") == 0) {
mask = TCL_WRITABLE;
} else if (strcmp(argv[4], "none") == 0) {
mask = 0;
} else {
Tcl_AppendResult(interp, "bad event name "", argv[4],
"": must be readable, writable, or none", (char *) NULL);
return TCL_ERROR;
}
esPtr->mask = mask;
Tcl_CreateChannelHandler((Tcl_Channel) chanPtr, mask,
TclChannelEventScriptInvoker, (ClientData) esPtr);
return TCL_OK;
}
Tcl_AppendResult(interp, "bad command ", cmd, ", must be one of ",
"add, delete, list, set, or removeall", (char *) NULL);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* TestWrongNumArgsObjCmd --
*
* Test the Tcl_WrongNumArgs function.
*
* Results:
* Standard Tcl result.
*
* Side effects:
* Sets interpreter result.
*
*----------------------------------------------------------------------
*/
static int
TestWrongNumArgsObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int i, length;
char *msg;
if (objc < 3) {
/*
* Don't use Tcl_WrongNumArgs here, as that is the function
* we want to test!
*/
Tcl_SetResult(interp, "insufficient arguments", TCL_STATIC);
return TCL_ERROR;
}
if (Tcl_GetIntFromObj(interp, objv[1], &i) != TCL_OK) {
return TCL_ERROR;
}
msg = Tcl_GetStringFromObj(objv[2], &length);
if (length == 0) {
msg = NULL;
}
if (i > objc - 3) {
/*
* Asked for more arguments than were given.
*/
Tcl_SetResult(interp, "insufficient arguments", TCL_STATIC);
return TCL_ERROR;
}
Tcl_WrongNumArgs(interp, i, &(objv[3]), msg);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestGetIndexFromObjStructObjCmd --
*
* Test the Tcl_GetIndexFromObjStruct function.
*
* Results:
* Standard Tcl result.
*
* Side effects:
* Sets interpreter result.
*
*----------------------------------------------------------------------
*/
static int
TestGetIndexFromObjStructObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
char *ary[] = {
"a", "b", "c", "d", "e", "f", (char *)NULL,(char *)NULL
};
int idx,target;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "argument targetvalue");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObjStruct(interp, objv[1], ary, 2*sizeof(char *),
"dummy", 0, &idx) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetIntFromObj(interp, objv[2], &target) != TCL_OK) {
return TCL_ERROR;
}
if (idx != target) {
char buffer[64];
sprintf(buffer, "%d", idx);
Tcl_AppendResult(interp, "index value comparison failed: got ",
buffer, NULL);
sprintf(buffer, "%d", target);
Tcl_AppendResult(interp, " when ", buffer, " expected", NULL);
return TCL_ERROR;
}
Tcl_WrongNumArgs(interp, 3, objv, NULL);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestFilesystemObjCmd --
*
* This procedure implements the "testfilesystem" command. It is
* used to test Tcl_FSRegister, Tcl_FSUnregister, and can be used
* to test that the pluggable filesystem works.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Inserts or removes a filesystem from Tcl's stack.
*
*----------------------------------------------------------------------
*/
static int
TestFilesystemObjCmd(dummy, interp, objc, objv)
ClientData dummy;
Tcl_Interp *interp;
int objc;
Tcl_Obj *CONST objv[];
{
int res, boolVal;
char *msg;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "boolean");
return TCL_ERROR;
}
if (Tcl_GetBooleanFromObj(interp, objv[1], &boolVal) != TCL_OK) {
return TCL_ERROR;
}
if (boolVal) {
res = Tcl_FSRegister((ClientData)interp, &testReportingFilesystem);
msg = (res == TCL_OK) ? "registered" : "failed";
} else {
res = Tcl_FSUnregister(&testReportingFilesystem);
msg = (res == TCL_OK) ? "unregistered" : "failed";
}
Tcl_SetResult(interp, msg, TCL_VOLATILE);
return res;
}
static int
TestReportInFilesystem(Tcl_Obj *pathPtr, ClientData *clientDataPtr)
{
static Tcl_Obj* lastPathPtr = NULL;
if (pathPtr == lastPathPtr) {
/* Reject all files second time around */
return -1;
} else {
Tcl_Obj * newPathPtr;
/* Try to claim all files first time around */
newPathPtr = Tcl_DuplicateObj(pathPtr);
lastPathPtr = newPathPtr;
Tcl_IncrRefCount(newPathPtr);
if (Tcl_FSGetFileSystemForPath(newPathPtr) == NULL) {
/* Nothing claimed it. Therefore we don't either */
Tcl_DecrRefCount(newPathPtr);
lastPathPtr = NULL;
return -1;
} else {
lastPathPtr = NULL;
*clientDataPtr = (ClientData) newPathPtr;
return TCL_OK;
}
}
}
/*
* Simple helper function to extract the native vfs representation of a
* path object, or NULL if no such representation exists.
*/
static Tcl_Obj*
TestReportGetNativePath(Tcl_Obj* pathObjPtr) {
return (Tcl_Obj*) Tcl_FSGetInternalRep(pathObjPtr, &testReportingFilesystem);
}
static void
TestReportFreeInternalRep(ClientData clientData) {
Tcl_Obj *nativeRep = (Tcl_Obj*)clientData;
if (nativeRep != NULL) {
/* Free the path */
Tcl_DecrRefCount(nativeRep);
}
}
static ClientData
TestReportDupInternalRep(ClientData clientData) {
Tcl_Obj *original = (Tcl_Obj*)clientData;
Tcl_IncrRefCount(original);
return clientData;
}
static void
TestReport(cmd, path, arg2)
CONST char* cmd;
Tcl_Obj* path;
Tcl_Obj* arg2;
{
Tcl_Interp* interp = (Tcl_Interp*) Tcl_FSData(&testReportingFilesystem);
if (interp == NULL) {
/* This is bad, but not much we can do about it */
} else {
/*
* No idea why I decided to program this up using the
* old string-based API, but there you go. We should
* convert it to objects.
*/
Tcl_SavedResult savedResult;
Tcl_DString ds;
Tcl_DStringInit(&ds);
Tcl_DStringAppend(&ds, "lappend filesystemReport ",-1);
Tcl_DStringStartSublist(&ds);
Tcl_DStringAppendElement(&ds, cmd);
if (path != NULL) {
Tcl_DStringAppendElement(&ds, Tcl_GetString(path));
}
if (arg2 != NULL) {
Tcl_DStringAppendElement(&ds, Tcl_GetString(arg2));
}
Tcl_DStringEndSublist(&ds);
Tcl_SaveResult(interp, &savedResult);
Tcl_Eval(interp, Tcl_DStringValue(&ds));
Tcl_DStringFree(&ds);
Tcl_RestoreResult(interp, &savedResult);
}
}
static int
TestReportStat(path, buf)
Tcl_Obj *path; /* Path of file to stat (in current CP). */
Tcl_StatBuf *buf; /* Filled with results of stat call. */
{
TestReport("stat",path, NULL);
return Tcl_FSStat(TestReportGetNativePath(path),buf);
}
static int
TestReportLstat(path, buf)
Tcl_Obj *path; /* Path of file to stat (in current CP). */
Tcl_StatBuf *buf; /* Filled with results of stat call. */
{
TestReport("lstat",path, NULL);
return Tcl_FSLstat(TestReportGetNativePath(path),buf);
}
static int
TestReportAccess(path, mode)
Tcl_Obj *path; /* Path of file to access (in current CP). */
int mode; /* Permission setting. */
{
TestReport("access",path,NULL);
return Tcl_FSAccess(TestReportGetNativePath(path),mode);
}
static Tcl_Channel
TestReportOpenFileChannel(interp, fileName, mode, permissions)
Tcl_Interp *interp; /* Interpreter for error reporting;
* can be NULL. */
Tcl_Obj *fileName; /* Name of file to open. */
int mode; /* POSIX open mode. */
int permissions; /* If the open involves creating a
* file, with what modes to create
* it? */
{
TestReport("open",fileName, NULL);
return TclpOpenFileChannel(interp, TestReportGetNativePath(fileName),
mode, permissions);
}
static int
TestReportMatchInDirectory(interp, resultPtr, dirPtr, pattern, types)
Tcl_Interp *interp; /* Interpreter to receive results. */
Tcl_Obj *resultPtr; /* Object to lappend results. */
Tcl_Obj *dirPtr; /* Contains path to directory to search. */
CONST char *pattern; /* Pattern to match against. */
Tcl_GlobTypeData *types; /* Object containing list of acceptable types.
* May be NULL. */
{
if (types != NULL && types->type & TCL_GLOB_TYPE_MOUNT) {
TestReport("matchmounts",dirPtr, NULL);
return TCL_OK;
} else {
TestReport("matchindirectory",dirPtr, NULL);
return Tcl_FSMatchInDirectory(interp, resultPtr,
TestReportGetNativePath(dirPtr), pattern,
types);
}
}
static int
TestReportChdir(dirName)
Tcl_Obj *dirName;
{
TestReport("chdir",dirName,NULL);
return Tcl_FSChdir(TestReportGetNativePath(dirName));
}
static int
TestReportLoadFile(interp, fileName,
handlePtr, unloadProcPtr)
Tcl_Interp *interp; /* Used for error reporting. */
Tcl_Obj *fileName; /* Name of the file containing the desired
* code. */
Tcl_LoadHandle *handlePtr; /* Filled with token for dynamically loaded
* file which will be passed back to
* (*unloadProcPtr)() to unload the file. */
Tcl_FSUnloadFileProc **unloadProcPtr;
/* Filled with address of Tcl_FSUnloadFileProc
* function which should be used for
* this file. */
{
TestReport("loadfile",fileName,NULL);
return Tcl_FSLoadFile(interp, TestReportGetNativePath(fileName), NULL, NULL,
NULL, NULL, handlePtr, unloadProcPtr);
}
static Tcl_Obj *
TestReportLink(path, to, linkType)
Tcl_Obj *path; /* Path of file to readlink or link */
Tcl_Obj *to; /* Path of file to link to, or NULL */
int linkType;
{
TestReport("link",path,to);
return Tcl_FSLink(TestReportGetNativePath(path), to, linkType);
}
static int
TestReportRenameFile(src, dst)
Tcl_Obj *src; /* Pathname of file or dir to be renamed
* (UTF-8). */
Tcl_Obj *dst; /* New pathname of file or directory
* (UTF-8). */
{
TestReport("renamefile",src,dst);
return Tcl_FSRenameFile(TestReportGetNativePath(src),
TestReportGetNativePath(dst));
}
static int
TestReportCopyFile(src, dst)
Tcl_Obj *src; /* Pathname of file to be copied (UTF-8). */
Tcl_Obj *dst; /* Pathname of file to copy to (UTF-8). */
{
TestReport("copyfile",src,dst);
return Tcl_FSCopyFile(TestReportGetNativePath(src),
TestReportGetNativePath(dst));
}
static int
TestReportDeleteFile(path)
Tcl_Obj *path; /* Pathname of file to be removed (UTF-8). */
{
TestReport("deletefile",path,NULL);
return Tcl_FSDeleteFile(TestReportGetNativePath(path));
}
static int
TestReportCreateDirectory(path)
Tcl_Obj *path; /* Pathname of directory to create (UTF-8). */
{
TestReport("createdirectory",path,NULL);
return Tcl_FSCreateDirectory(TestReportGetNativePath(path));
}
static int
TestReportCopyDirectory(src, dst, errorPtr)
Tcl_Obj *src; /* Pathname of directory to be copied
* (UTF-8). */
Tcl_Obj *dst; /* Pathname of target directory (UTF-8). */
Tcl_Obj **errorPtr; /* If non-NULL, to be filled with UTF-8 name
* of file causing error. */
{
TestReport("copydirectory",src,dst);
return Tcl_FSCopyDirectory(TestReportGetNativePath(src),
TestReportGetNativePath(dst), errorPtr);
}
static int
TestReportRemoveDirectory(path, recursive, errorPtr)
Tcl_Obj *path; /* Pathname of directory to be removed
* (UTF-8). */
int recursive; /* If non-zero, removes directories that
* are nonempty. Otherwise, will only remove
* empty directories. */
Tcl_Obj **errorPtr; /* If non-NULL, to be filled with UTF-8 name
* of file causing error. */
{
TestReport("removedirectory",path,NULL);
return Tcl_FSRemoveDirectory(TestReportGetNativePath(path), recursive,
errorPtr);
}
static CONST char**
TestReportFileAttrStrings(fileName, objPtrRef)
Tcl_Obj* fileName;
Tcl_Obj** objPtrRef;
{
TestReport("fileattributestrings",fileName,NULL);
return Tcl_FSFileAttrStrings(TestReportGetNativePath(fileName), objPtrRef);
}
static int
TestReportFileAttrsGet(interp, index, fileName, objPtrRef)
Tcl_Interp *interp; /* The interpreter for error reporting. */
int index; /* index of the attribute command. */
Tcl_Obj *fileName; /* filename we are operating on. */
Tcl_Obj **objPtrRef; /* for output. */
{
TestReport("fileattributesget",fileName,NULL);
return Tcl_FSFileAttrsGet(interp, index,
TestReportGetNativePath(fileName), objPtrRef);
}
static int
TestReportFileAttrsSet(interp, index, fileName, objPtr)
Tcl_Interp *interp; /* The interpreter for error reporting. */
int index; /* index of the attribute command. */
Tcl_Obj *fileName; /* filename we are operating on. */
Tcl_Obj *objPtr; /* for input. */
{
TestReport("fileattributesset",fileName,objPtr);
return Tcl_FSFileAttrsSet(interp, index,
TestReportGetNativePath(fileName), objPtr);
}
static int
TestReportUtime (fileName, tval)
Tcl_Obj* fileName;
struct utimbuf *tval;
{
TestReport("utime",fileName,NULL);
return Tcl_FSUtime(TestReportGetNativePath(fileName), tval);
}
static int
TestReportNormalizePath(interp, pathPtr, nextCheckpoint)
Tcl_Interp *interp;
Tcl_Obj *pathPtr;
int nextCheckpoint;
{
TestReport("normalizepath",pathPtr,NULL);
return nextCheckpoint;
}
static int
SimplePathInFilesystem(Tcl_Obj *pathPtr, ClientData *clientDataPtr) {
CONST char *str = Tcl_GetString(pathPtr);
if (strncmp(str,"simplefs:/",10)) {
return -1;
}
return TCL_OK;
}
/*
* Since TclCopyChannel insists on an interpreter, we use this
* to simplify our test scripts. Would be better if it could
* copy without an interp
*/
static Tcl_Interp *simpleInterpPtr = NULL;
/* We use this to ensure we clean up after ourselves */
static Tcl_Obj *tempFile = NULL;
/*
* This is a very 'hacky' filesystem which is used just to
* test two important features of the vfs code: (1) that
* you can load a shared library from a vfs, (2) that when
* copying files from one fs to another, the 'mtime' is
* preserved.
*
* It treats any file in 'simplefs:/' as a file, and
* artificially creates a real file on the fly which it uses
* to extract information from. The real file it uses is
* whatever follows the trailing '/' (e.g. 'foo' in 'simplefs:/foo'),
* and that file is assumed to exist in the native pwd, and is
* copied over to the native temporary directory where it is
* accessed.
*
* Please do not consider this filesystem a model of how
* things are to be done. It is quite the opposite! But, it
* does allow us to test two important features.
*
* Finally: this fs can only be used from one interpreter.
*/
static int
TestSimpleFilesystemObjCmd(dummy, interp, objc, objv)
ClientData dummy;
Tcl_Interp *interp;
int objc;
Tcl_Obj *CONST objv[];
{
int res, boolVal;
char *msg;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "boolean");
return TCL_ERROR;
}
if (Tcl_GetBooleanFromObj(interp, objv[1], &boolVal) != TCL_OK) {
return TCL_ERROR;
}
if (boolVal) {
res = Tcl_FSRegister((ClientData)interp, &simpleFilesystem);
msg = (res == TCL_OK) ? "registered" : "failed";
simpleInterpPtr = interp;
} else {
if (tempFile != NULL) {
Tcl_FSDeleteFile(tempFile);
Tcl_DecrRefCount(tempFile);
tempFile = NULL;
}
res = Tcl_FSUnregister(&simpleFilesystem);
msg = (res == TCL_OK) ? "unregistered" : "failed";
simpleInterpPtr = NULL;
}
Tcl_SetResult(interp, msg, TCL_VOLATILE);
return res;
}
/*
* Treats a file name 'simplefs:/foo' by copying the file 'foo'
* in the current (native) directory to a temporary native file,
* and then returns that native file.
*/
static Tcl_Obj*
SimpleCopy(pathPtr)
Tcl_Obj *pathPtr; /* Name of file to copy. */
{
int res;
CONST char *str;
Tcl_Obj *origPtr;
Tcl_Obj *tempPtr;
tempPtr = TclpTempFileName();
Tcl_IncrRefCount(tempPtr);
/*
* We assume the same name in the current directory is ok.
*/
str = Tcl_GetString(pathPtr);
origPtr = Tcl_NewStringObj(str+10,-1);
Tcl_IncrRefCount(origPtr);
res = TclCrossFilesystemCopy(simpleInterpPtr, origPtr, tempPtr);
Tcl_DecrRefCount(origPtr);
if (res != TCL_OK) {
Tcl_FSDeleteFile(tempPtr);
Tcl_DecrRefCount(tempPtr);
return NULL;
}
return tempPtr;
}
static Tcl_Channel
SimpleOpenFileChannel(interp, pathPtr, mode, permissions)
Tcl_Interp *interp; /* Interpreter for error reporting;
* can be NULL. */
Tcl_Obj *pathPtr; /* Name of file to open. */
int mode; /* POSIX open mode. */
int permissions; /* If the open involves creating a
* file, with what modes to create
* it? */
{
Tcl_Obj *tempPtr;
Tcl_Channel chan;
if ((mode != 0) && !(mode & O_RDONLY)) {
Tcl_AppendResult(interp, "read-only",
(char *) NULL);
return NULL;
}
tempPtr = SimpleCopy(pathPtr);
if (tempPtr == NULL) {
return NULL;
}
chan = Tcl_FSOpenFileChannel(interp, tempPtr, "r", permissions);
if (tempFile != NULL) {
Tcl_FSDeleteFile(tempFile);
Tcl_DecrRefCount(tempFile);
tempFile = NULL;
}
/*
* Store file pointer in this global variable so we can delete
* it later
*/
tempFile = tempPtr;
return chan;
}
static int
SimpleAccess(pathPtr, mode)
Tcl_Obj *pathPtr; /* Path of file to access (in current CP). */
int mode; /* Permission setting. */
{
/* All files exist */
return TCL_OK;
}
static int
SimpleStat(pathPtr, bufPtr)
Tcl_Obj *pathPtr; /* Path of file to stat (in current CP). */
Tcl_StatBuf *bufPtr; /* Filled with results of stat call. */
{
Tcl_Obj *tempPtr = SimpleCopy(pathPtr);
if (tempPtr == NULL) {
/* We just pretend the file exists anyway */
return TCL_OK;
} else {
int res = Tcl_FSStat(tempPtr, bufPtr);
Tcl_FSDeleteFile(tempPtr);
Tcl_DecrRefCount(tempPtr);
return res;
}
}
static Tcl_Obj*
SimpleListVolumes(void)
{
/* Add one new volume */
Tcl_Obj *retVal;
retVal = Tcl_NewStringObj("simplefs:/",-1);
Tcl_IncrRefCount(retVal);
return retVal;
}
/*
* Used to check correct string-length determining in Tcl_NumUtfChars
*/
static int
TestNumUtfCharsCmd(clientData, interp, objc, objv)
ClientData clientData;
Tcl_Interp *interp;
int objc;
Tcl_Obj *CONST objv[];
{
if (objc > 1) {
int len = -1;
if (objc > 2) {
(void) Tcl_GetStringFromObj(objv[1], &len);
}
len = Tcl_NumUtfChars(Tcl_GetString(objv[1]), len);
Tcl_SetObjResult(interp, Tcl_NewIntObj(len));
}
return TCL_OK;
}