1/* 2 * tclTest.c -- 3 * 4 * This file contains C command procedures for a bunch of additional 5 * Tcl commands that are used for testing out Tcl's C interfaces. 6 * These commands are not normally included in Tcl applications; 7 * they're only used for testing. 8 * 9 * Copyright (c) 1993-1994 The Regents of the University of California. 10 * Copyright (c) 1994-1997 Sun Microsystems, Inc. 11 * Copyright (c) 1998-2000 Ajuba Solutions. 12 * Copyright (c) 2003 by Kevin B. Kenny. All rights reserved. 13 * 14 * See the file "license.terms" for information on usage and redistribution 15 * of this file, and for a DISCLAIMER OF ALL WARRANTIES. 16 * 17 * RCS: @(#) $Id: tclTest.c,v 1.62.2.15 2008/03/07 20:26:22 dgp Exp $ 18 */ 19 20#define TCL_TEST 21#include "tclInt.h" 22#include "tclPort.h" 23 24/* 25 * Required for Testregexp*Cmd 26 */ 27#include "tclRegexp.h" 28 29/* 30 * Required for TestlocaleCmd 31 */ 32#include <locale.h> 33 34/* 35 * Required for the TestChannelCmd and TestChannelEventCmd 36 */ 37#include "tclIO.h" 38 39/* 40 * Declare external functions used in Windows tests. 41 */ 42 43/* 44 * Dynamic string shared by TestdcallCmd and DelCallbackProc; used 45 * to collect the results of the various deletion callbacks. 46 */ 47 48static Tcl_DString delString; 49static Tcl_Interp *delInterp; 50 51/* 52 * One of the following structures exists for each asynchronous 53 * handler created by the "testasync" command". 54 */ 55 56typedef struct TestAsyncHandler { 57 int id; /* Identifier for this handler. */ 58 Tcl_AsyncHandler handler; /* Tcl's token for the handler. */ 59 char *command; /* Command to invoke when the 60 * handler is invoked. */ 61 struct TestAsyncHandler *nextPtr; /* Next is list of handlers. */ 62} TestAsyncHandler; 63 64static TestAsyncHandler *firstHandler = NULL; 65 66/* 67 * The dynamic string below is used by the "testdstring" command 68 * to test the dynamic string facilities. 69 */ 70 71static Tcl_DString dstring; 72 73/* 74 * The command trace below is used by the "testcmdtraceCmd" command 75 * to test the command tracing facilities. 76 */ 77 78static Tcl_Trace cmdTrace; 79 80/* 81 * One of the following structures exists for each command created 82 * by TestdelCmd: 83 */ 84 85typedef struct DelCmd { 86 Tcl_Interp *interp; /* Interpreter in which command exists. */ 87 char *deleteCmd; /* Script to execute when command is 88 * deleted. Malloc'ed. */ 89} DelCmd; 90 91/* 92 * The following is used to keep track of an encoding that invokes a Tcl 93 * command. 94 */ 95 96typedef struct TclEncoding { 97 Tcl_Interp *interp; 98 char *toUtfCmd; 99 char *fromUtfCmd; 100} TclEncoding; 101 102/* 103 * The counter below is used to determine if the TestsaveresultFree 104 * routine was called for a result. 105 */ 106 107static int freeCount; 108 109/* 110 * Boolean flag used by the "testsetmainloop" and "testexitmainloop" 111 * commands. 112 */ 113static int exitMainLoop = 0; 114 115/* 116 * Event structure used in testing the event queue management procedures. 117 */ 118typedef struct TestEvent { 119 Tcl_Event header; /* Header common to all events */ 120 Tcl_Interp* interp; /* Interpreter that will handle the event */ 121 Tcl_Obj* command; /* Command to evaluate when the event occurs */ 122 Tcl_Obj* tag; /* Tag for this event used to delete it */ 123} TestEvent; 124 125/* 126 * Forward declarations for procedures defined later in this file: 127 */ 128 129int Tcltest_Init _ANSI_ARGS_((Tcl_Interp *interp)); 130static int AsyncHandlerProc _ANSI_ARGS_((ClientData clientData, 131 Tcl_Interp *interp, int code)); 132static void CleanupTestSetassocdataTests _ANSI_ARGS_(( 133 ClientData clientData, Tcl_Interp *interp)); 134static void CmdDelProc1 _ANSI_ARGS_((ClientData clientData)); 135static void CmdDelProc2 _ANSI_ARGS_((ClientData clientData)); 136static int CmdProc1 _ANSI_ARGS_((ClientData clientData, 137 Tcl_Interp *interp, int argc, CONST char **argv)); 138static int CmdProc2 _ANSI_ARGS_((ClientData clientData, 139 Tcl_Interp *interp, int argc, CONST char **argv)); 140static void CmdTraceDeleteProc _ANSI_ARGS_(( 141 ClientData clientData, Tcl_Interp *interp, 142 int level, char *command, Tcl_CmdProc *cmdProc, 143 ClientData cmdClientData, int argc, 144 char **argv)); 145static void CmdTraceProc _ANSI_ARGS_((ClientData clientData, 146 Tcl_Interp *interp, int level, char *command, 147 Tcl_CmdProc *cmdProc, ClientData cmdClientData, 148 int argc, char **argv)); 149static int CreatedCommandProc _ANSI_ARGS_(( 150 ClientData clientData, Tcl_Interp *interp, 151 int argc, CONST char **argv)); 152static int CreatedCommandProc2 _ANSI_ARGS_(( 153 ClientData clientData, Tcl_Interp *interp, 154 int argc, CONST char **argv)); 155static void DelCallbackProc _ANSI_ARGS_((ClientData clientData, 156 Tcl_Interp *interp)); 157static int DelCmdProc _ANSI_ARGS_((ClientData clientData, 158 Tcl_Interp *interp, int argc, CONST char **argv)); 159static void DelDeleteProc _ANSI_ARGS_((ClientData clientData)); 160static void EncodingFreeProc _ANSI_ARGS_((ClientData clientData)); 161static int EncodingToUtfProc _ANSI_ARGS_((ClientData clientData, 162 CONST char *src, int srcLen, int flags, 163 Tcl_EncodingState *statePtr, char *dst, 164 int dstLen, int *srcReadPtr, int *dstWrotePtr, 165 int *dstCharsPtr)); 166static int EncodingFromUtfProc _ANSI_ARGS_((ClientData clientData, 167 CONST char *src, int srcLen, int flags, 168 Tcl_EncodingState *statePtr, char *dst, 169 int dstLen, int *srcReadPtr, int *dstWrotePtr, 170 int *dstCharsPtr)); 171static void ExitProcEven _ANSI_ARGS_((ClientData clientData)); 172static void ExitProcOdd _ANSI_ARGS_((ClientData clientData)); 173static int GetTimesCmd _ANSI_ARGS_((ClientData clientData, 174 Tcl_Interp *interp, int argc, CONST char **argv)); 175static void MainLoop _ANSI_ARGS_((void)); 176static int NoopCmd _ANSI_ARGS_((ClientData clientData, 177 Tcl_Interp *interp, int argc, CONST char **argv)); 178static int NoopObjCmd _ANSI_ARGS_((ClientData clientData, 179 Tcl_Interp *interp, int objc, 180 Tcl_Obj *CONST objv[])); 181static int ObjTraceProc _ANSI_ARGS_(( ClientData clientData, 182 Tcl_Interp* interp, 183 int level, 184 CONST char* command, 185 Tcl_Command commandToken, 186 int objc, 187 Tcl_Obj *CONST objv[] )); 188static void ObjTraceDeleteProc _ANSI_ARGS_(( ClientData )); 189static void PrintParse _ANSI_ARGS_((Tcl_Interp *interp, 190 Tcl_Parse *parsePtr)); 191static void SpecialFree _ANSI_ARGS_((char *blockPtr)); 192static int StaticInitProc _ANSI_ARGS_((Tcl_Interp *interp)); 193static int TestaccessprocCmd _ANSI_ARGS_((ClientData dummy, 194 Tcl_Interp *interp, int argc, CONST char **argv)); 195static int PretendTclpAccess _ANSI_ARGS_((CONST char *path, 196 int mode)); 197static int TestAccessProc1 _ANSI_ARGS_((CONST char *path, 198 int mode)); 199static int TestAccessProc2 _ANSI_ARGS_((CONST char *path, 200 int mode)); 201static int TestAccessProc3 _ANSI_ARGS_((CONST char *path, 202 int mode)); 203static int TestasyncCmd _ANSI_ARGS_((ClientData dummy, 204 Tcl_Interp *interp, int argc, CONST char **argv)); 205static int TestcmdinfoCmd _ANSI_ARGS_((ClientData dummy, 206 Tcl_Interp *interp, int argc, CONST char **argv)); 207static int TestcmdtokenCmd _ANSI_ARGS_((ClientData dummy, 208 Tcl_Interp *interp, int argc, CONST char **argv)); 209static int TestcmdtraceCmd _ANSI_ARGS_((ClientData dummy, 210 Tcl_Interp *interp, int argc, CONST char **argv)); 211static int TestcreatecommandCmd _ANSI_ARGS_((ClientData dummy, 212 Tcl_Interp *interp, int argc, CONST char **argv)); 213static int TestdcallCmd _ANSI_ARGS_((ClientData dummy, 214 Tcl_Interp *interp, int argc, CONST char **argv)); 215static int TestdelCmd _ANSI_ARGS_((ClientData dummy, 216 Tcl_Interp *interp, int argc, CONST char **argv)); 217static int TestdelassocdataCmd _ANSI_ARGS_((ClientData dummy, 218 Tcl_Interp *interp, int argc, CONST char **argv)); 219static int TestdstringCmd _ANSI_ARGS_((ClientData dummy, 220 Tcl_Interp *interp, int argc, CONST char **argv)); 221static int TestencodingObjCmd _ANSI_ARGS_((ClientData dummy, 222 Tcl_Interp *interp, int objc, 223 Tcl_Obj *CONST objv[])); 224static int TestevalexObjCmd _ANSI_ARGS_((ClientData dummy, 225 Tcl_Interp *interp, int objc, 226 Tcl_Obj *CONST objv[])); 227static int TestevalobjvObjCmd _ANSI_ARGS_((ClientData dummy, 228 Tcl_Interp *interp, int objc, 229 Tcl_Obj *CONST objv[])); 230static int TesteventObjCmd _ANSI_ARGS_((ClientData unused, 231 Tcl_Interp* interp, 232 int argc, 233 Tcl_Obj *CONST objv[])); 234static int TesteventProc _ANSI_ARGS_((Tcl_Event* event, 235 int flags)); 236static int TesteventDeleteProc _ANSI_ARGS_(( 237 Tcl_Event* event, 238 ClientData clientData)); 239static int TestexithandlerCmd _ANSI_ARGS_((ClientData dummy, 240 Tcl_Interp *interp, int argc, CONST char **argv)); 241static int TestexprlongCmd _ANSI_ARGS_((ClientData dummy, 242 Tcl_Interp *interp, int argc, CONST char **argv)); 243static int TestexprlongobjCmd _ANSI_ARGS_((ClientData dummy, 244 Tcl_Interp *interp, int objc, 245 Tcl_Obj *CONST objv[])); 246static int TestexprparserObjCmd _ANSI_ARGS_((ClientData dummy, 247 Tcl_Interp *interp, int objc, 248 Tcl_Obj *CONST objv[])); 249static int TestexprstringCmd _ANSI_ARGS_((ClientData dummy, 250 Tcl_Interp *interp, int argc, CONST char **argv)); 251static int TestfileCmd _ANSI_ARGS_((ClientData dummy, 252 Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); 253static int TestfilelinkCmd _ANSI_ARGS_((ClientData dummy, 254 Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); 255static int TestfeventCmd _ANSI_ARGS_((ClientData dummy, 256 Tcl_Interp *interp, int argc, CONST char **argv)); 257static int TestgetassocdataCmd _ANSI_ARGS_((ClientData dummy, 258 Tcl_Interp *interp, int argc, CONST char **argv)); 259static int TestgetplatformCmd _ANSI_ARGS_((ClientData dummy, 260 Tcl_Interp *interp, int argc, CONST char **argv)); 261static int TestgetvarfullnameCmd _ANSI_ARGS_(( 262 ClientData dummy, Tcl_Interp *interp, 263 int objc, Tcl_Obj *CONST objv[])); 264static int TestinterpdeleteCmd _ANSI_ARGS_((ClientData dummy, 265 Tcl_Interp *interp, int argc, CONST char **argv)); 266static int TestlinkCmd _ANSI_ARGS_((ClientData dummy, 267 Tcl_Interp *interp, int argc, CONST char **argv)); 268static int TestlocaleCmd _ANSI_ARGS_((ClientData dummy, 269 Tcl_Interp *interp, int objc, 270 Tcl_Obj *CONST objv[])); 271static int TestMathFunc _ANSI_ARGS_((ClientData clientData, 272 Tcl_Interp *interp, Tcl_Value *args, 273 Tcl_Value *resultPtr)); 274static int TestMathFunc2 _ANSI_ARGS_((ClientData clientData, 275 Tcl_Interp *interp, Tcl_Value *args, 276 Tcl_Value *resultPtr)); 277static int TestmainthreadCmd _ANSI_ARGS_((ClientData dummy, 278 Tcl_Interp *interp, int argc, CONST char **argv)); 279static int TestsetmainloopCmd _ANSI_ARGS_((ClientData dummy, 280 Tcl_Interp *interp, int argc, CONST char **argv)); 281static int TestexitmainloopCmd _ANSI_ARGS_((ClientData dummy, 282 Tcl_Interp *interp, int argc, CONST char **argv)); 283static Tcl_Channel PretendTclpOpenFileChannel _ANSI_ARGS_(( 284 Tcl_Interp *interp, CONST char *fileName, 285 CONST char *modeString, int permissions)); 286static Tcl_Channel TestOpenFileChannelProc1 _ANSI_ARGS_(( 287 Tcl_Interp *interp, CONST char *fileName, 288 CONST char *modeString, int permissions)); 289static Tcl_Channel TestOpenFileChannelProc2 _ANSI_ARGS_(( 290 Tcl_Interp *interp, CONST char *fileName, 291 CONST char *modeString, int permissions)); 292static Tcl_Channel TestOpenFileChannelProc3 _ANSI_ARGS_(( 293 Tcl_Interp *interp, CONST char *fileName, 294 CONST char *modeString, int permissions)); 295static int TestpanicCmd _ANSI_ARGS_((ClientData dummy, 296 Tcl_Interp *interp, int argc, CONST char **argv)); 297static int TestparserObjCmd _ANSI_ARGS_((ClientData dummy, 298 Tcl_Interp *interp, int objc, 299 Tcl_Obj *CONST objv[])); 300static int TestparsevarObjCmd _ANSI_ARGS_((ClientData dummy, 301 Tcl_Interp *interp, int objc, 302 Tcl_Obj *CONST objv[])); 303static int TestparsevarnameObjCmd _ANSI_ARGS_((ClientData dummy, 304 Tcl_Interp *interp, int objc, 305 Tcl_Obj *CONST objv[])); 306static int TestregexpObjCmd _ANSI_ARGS_((ClientData dummy, 307 Tcl_Interp *interp, int objc, 308 Tcl_Obj *CONST objv[])); 309static void TestregexpXflags _ANSI_ARGS_((char *string, 310 int length, int *cflagsPtr, int *eflagsPtr)); 311static int TestsaveresultCmd _ANSI_ARGS_((ClientData dummy, 312 Tcl_Interp *interp, int objc, 313 Tcl_Obj *CONST objv[])); 314static void TestsaveresultFree _ANSI_ARGS_((char *blockPtr)); 315static int TestsetassocdataCmd _ANSI_ARGS_((ClientData dummy, 316 Tcl_Interp *interp, int argc, CONST char **argv)); 317static int TestsetCmd _ANSI_ARGS_((ClientData dummy, 318 Tcl_Interp *interp, int argc, CONST char **argv)); 319static int TestseterrorcodeCmd _ANSI_ARGS_((ClientData dummy, 320 Tcl_Interp *interp, int argc, CONST char **argv)); 321static int TestsetobjerrorcodeCmd _ANSI_ARGS_(( 322 ClientData dummy, Tcl_Interp *interp, 323 int objc, Tcl_Obj *CONST objv[])); 324static int TestopenfilechannelprocCmd _ANSI_ARGS_(( 325 ClientData dummy, Tcl_Interp *interp, int argc, 326 CONST char **argv)); 327static int TestsetplatformCmd _ANSI_ARGS_((ClientData dummy, 328 Tcl_Interp *interp, int argc, CONST char **argv)); 329static int TeststaticpkgCmd _ANSI_ARGS_((ClientData dummy, 330 Tcl_Interp *interp, int argc, CONST char **argv)); 331static int PretendTclpStat _ANSI_ARGS_((CONST char *path, 332 struct stat *buf)); 333static int TestStatProc1 _ANSI_ARGS_((CONST char *path, 334 struct stat *buf)); 335static int TestStatProc2 _ANSI_ARGS_((CONST char *path, 336 struct stat *buf)); 337static int TestStatProc3 _ANSI_ARGS_((CONST char *path, 338 struct stat *buf)); 339static int TeststatprocCmd _ANSI_ARGS_((ClientData dummy, 340 Tcl_Interp *interp, int argc, CONST char **argv)); 341static int TesttranslatefilenameCmd _ANSI_ARGS_((ClientData dummy, 342 Tcl_Interp *interp, int argc, CONST char **argv)); 343static int TestupvarCmd _ANSI_ARGS_((ClientData dummy, 344 Tcl_Interp *interp, int argc, CONST char **argv)); 345static int TestWrongNumArgsObjCmd _ANSI_ARGS_(( 346 ClientData clientData, Tcl_Interp *interp, 347 int objc, Tcl_Obj *CONST objv[])); 348static int TestGetIndexFromObjStructObjCmd _ANSI_ARGS_(( 349 ClientData clientData, Tcl_Interp *interp, 350 int objc, Tcl_Obj *CONST objv[])); 351static int TestChannelCmd _ANSI_ARGS_((ClientData clientData, 352 Tcl_Interp *interp, int argc, CONST char **argv)); 353static int TestChannelEventCmd _ANSI_ARGS_((ClientData clientData, 354 Tcl_Interp *interp, int argc, CONST char **argv)); 355/* Filesystem testing */ 356 357static int TestFilesystemObjCmd _ANSI_ARGS_((ClientData dummy, 358 Tcl_Interp *interp, int objc, 359 Tcl_Obj *CONST objv[])); 360static int TestSimpleFilesystemObjCmd _ANSI_ARGS_(( 361 ClientData dummy, Tcl_Interp *interp, int objc, 362 Tcl_Obj *CONST objv[])); 363 364static void TestReport _ANSI_ARGS_ ((CONST char* cmd, Tcl_Obj* arg1, 365 Tcl_Obj* arg2)); 366 367static Tcl_Obj* TestReportGetNativePath _ANSI_ARGS_ (( 368 Tcl_Obj* pathObjPtr)); 369 370static int TestReportStat _ANSI_ARGS_ ((Tcl_Obj *path, 371 Tcl_StatBuf *buf)); 372static int TestReportAccess _ANSI_ARGS_ ((Tcl_Obj *path, 373 int mode)); 374static Tcl_Channel TestReportOpenFileChannel _ANSI_ARGS_ (( 375 Tcl_Interp *interp, Tcl_Obj *fileName, 376 int mode, int permissions)); 377static int TestReportMatchInDirectory _ANSI_ARGS_ (( 378 Tcl_Interp *interp, Tcl_Obj *resultPtr, 379 Tcl_Obj *dirPtr, CONST char *pattern, 380 Tcl_GlobTypeData *types)); 381static int TestReportChdir _ANSI_ARGS_ ((Tcl_Obj *dirName)); 382static int TestReportLstat _ANSI_ARGS_ ((Tcl_Obj *path, 383 Tcl_StatBuf *buf)); 384static int TestReportCopyFile _ANSI_ARGS_ ((Tcl_Obj *src, 385 Tcl_Obj *dst)); 386static int TestReportDeleteFile _ANSI_ARGS_ ((Tcl_Obj *path)); 387static int TestReportRenameFile _ANSI_ARGS_ ((Tcl_Obj *src, 388 Tcl_Obj *dst)); 389static int TestReportCreateDirectory _ANSI_ARGS_ ((Tcl_Obj *path)); 390static int TestReportCopyDirectory _ANSI_ARGS_ ((Tcl_Obj *src, 391 Tcl_Obj *dst, Tcl_Obj **errorPtr)); 392static int TestReportRemoveDirectory _ANSI_ARGS_ ((Tcl_Obj *path, 393 int recursive, Tcl_Obj **errorPtr)); 394static int TestReportLoadFile _ANSI_ARGS_ ((Tcl_Interp *interp, 395 Tcl_Obj *fileName, 396 Tcl_LoadHandle *handlePtr, 397 Tcl_FSUnloadFileProc **unloadProcPtr)); 398static Tcl_Obj * TestReportLink _ANSI_ARGS_ ((Tcl_Obj *path, 399 Tcl_Obj *to, int linkType)); 400static CONST char** TestReportFileAttrStrings _ANSI_ARGS_ (( 401 Tcl_Obj *fileName, Tcl_Obj **objPtrRef)); 402static int TestReportFileAttrsGet _ANSI_ARGS_ ((Tcl_Interp *interp, 403 int index, Tcl_Obj *fileName, Tcl_Obj **objPtrRef)); 404static int TestReportFileAttrsSet _ANSI_ARGS_ ((Tcl_Interp *interp, 405 int index, Tcl_Obj *fileName, Tcl_Obj *objPtr)); 406static int TestReportUtime _ANSI_ARGS_ ((Tcl_Obj *fileName, 407 struct utimbuf *tval)); 408static int TestReportNormalizePath _ANSI_ARGS_ (( 409 Tcl_Interp *interp, Tcl_Obj *pathPtr, 410 int nextCheckpoint)); 411static int TestReportInFilesystem _ANSI_ARGS_ ((Tcl_Obj *pathPtr, ClientData *clientDataPtr)); 412static void TestReportFreeInternalRep _ANSI_ARGS_ ((ClientData clientData)); 413static ClientData TestReportDupInternalRep _ANSI_ARGS_ ((ClientData clientData)); 414 415static int SimpleStat _ANSI_ARGS_ ((Tcl_Obj *path, 416 Tcl_StatBuf *buf)); 417static int SimpleAccess _ANSI_ARGS_ ((Tcl_Obj *path, 418 int mode)); 419static Tcl_Channel SimpleOpenFileChannel _ANSI_ARGS_ (( 420 Tcl_Interp *interp, Tcl_Obj *fileName, 421 int mode, int permissions)); 422static Tcl_Obj* SimpleListVolumes _ANSI_ARGS_ ((void)); 423static int SimplePathInFilesystem _ANSI_ARGS_ (( 424 Tcl_Obj *pathPtr, ClientData *clientDataPtr)); 425static Tcl_Obj* SimpleCopy _ANSI_ARGS_ ((Tcl_Obj *pathPtr)); 426static int TestNumUtfCharsCmd _ANSI_ARGS_((ClientData clientData, 427 Tcl_Interp *interp, int objc, 428 Tcl_Obj *CONST objv[])); 429 430static Tcl_Filesystem testReportingFilesystem = { 431 "reporting", 432 sizeof(Tcl_Filesystem), 433 TCL_FILESYSTEM_VERSION_1, 434 &TestReportInFilesystem, /* path in */ 435 &TestReportDupInternalRep, 436 &TestReportFreeInternalRep, 437 NULL, /* native to norm */ 438 NULL, /* convert to native */ 439 &TestReportNormalizePath, 440 NULL, /* path type */ 441 NULL, /* separator */ 442 &TestReportStat, 443 &TestReportAccess, 444 &TestReportOpenFileChannel, 445 &TestReportMatchInDirectory, 446 &TestReportUtime, 447 &TestReportLink, 448 NULL /* list volumes */, 449 &TestReportFileAttrStrings, 450 &TestReportFileAttrsGet, 451 &TestReportFileAttrsSet, 452 &TestReportCreateDirectory, 453 &TestReportRemoveDirectory, 454 &TestReportDeleteFile, 455 &TestReportCopyFile, 456 &TestReportRenameFile, 457 &TestReportCopyDirectory, 458 &TestReportLstat, 459 &TestReportLoadFile, 460 NULL /* cwd */, 461 &TestReportChdir 462}; 463 464static Tcl_Filesystem simpleFilesystem = { 465 "simple", 466 sizeof(Tcl_Filesystem), 467 TCL_FILESYSTEM_VERSION_1, 468 &SimplePathInFilesystem, 469 NULL, 470 NULL, 471 /* No internal to normalized, since we don't create any 472 * pure 'internal' Tcl_Obj path representations */ 473 NULL, 474 /* No create native rep function, since we don't use it 475 * or 'Tcl_FSNewNativePath' */ 476 NULL, 477 /* Normalize path isn't needed - we assume paths only have 478 * one representation */ 479 NULL, 480 NULL, 481 NULL, 482 &SimpleStat, 483 &SimpleAccess, 484 &SimpleOpenFileChannel, 485 NULL, 486 NULL, 487 /* We choose not to support symbolic links inside our vfs's */ 488 NULL, 489 &SimpleListVolumes, 490 NULL, 491 NULL, 492 NULL, 493 NULL, 494 NULL, 495 NULL, 496 /* No copy file - fallback will occur at Tcl level */ 497 NULL, 498 /* No rename file - fallback will occur at Tcl level */ 499 NULL, 500 /* No copy directory - fallback will occur at Tcl level */ 501 NULL, 502 /* Use stat for lstat */ 503 NULL, 504 /* No load - fallback on core implementation */ 505 NULL, 506 /* We don't need a getcwd or chdir - fallback on Tcl's versions */ 507 NULL, 508 NULL 509}; 510 511 512/* 513 * External (platform specific) initialization routine, these declarations 514 * explicitly don't use EXTERN since this code does not get compiled 515 * into the library: 516 */ 517 518extern int TclplatformtestInit _ANSI_ARGS_((Tcl_Interp *interp)); 519extern int TclThread_Init _ANSI_ARGS_((Tcl_Interp *interp)); 520 521/* 522 *---------------------------------------------------------------------- 523 * 524 * Tcltest_Init -- 525 * 526 * This procedure performs application-specific initialization. 527 * Most applications, especially those that incorporate additional 528 * packages, will have their own version of this procedure. 529 * 530 * Results: 531 * Returns a standard Tcl completion code, and leaves an error 532 * message in the interp's result if an error occurs. 533 * 534 * Side effects: 535 * Depends on the startup script. 536 * 537 *---------------------------------------------------------------------- 538 */ 539 540int 541Tcltest_Init(interp) 542 Tcl_Interp *interp; /* Interpreter for application. */ 543{ 544 Tcl_ValueType t3ArgTypes[2]; 545 546 Tcl_Obj *listPtr; 547 Tcl_Obj **objv; 548 int objc, index; 549 static CONST char *specialOptions[] = { 550 "-appinitprocerror", "-appinitprocdeleteinterp", 551 "-appinitprocclosestderr", "-appinitprocsetrcfile", (char *) NULL 552 }; 553 554#ifndef TCL_TIP268 555 if (Tcl_PkgProvide(interp, "Tcltest", TCL_VERSION) == TCL_ERROR) { 556#else 557 /* TIP #268: Full patchlevel instead of just major.minor */ 558 if (Tcl_PkgProvide(interp, "Tcltest", TCL_PATCH_LEVEL) == TCL_ERROR) { 559#endif 560 return TCL_ERROR; 561 } 562 563 /* 564 * Create additional commands and math functions for testing Tcl. 565 */ 566 567 Tcl_CreateCommand(interp, "gettimes", GetTimesCmd, (ClientData) 0, 568 (Tcl_CmdDeleteProc *) NULL); 569 Tcl_CreateCommand(interp, "noop", NoopCmd, (ClientData) 0, 570 (Tcl_CmdDeleteProc *) NULL); 571 Tcl_CreateObjCommand(interp, "noop", NoopObjCmd, (ClientData) 0, 572 (Tcl_CmdDeleteProc *) NULL); 573 Tcl_CreateObjCommand(interp, "testwrongnumargs", TestWrongNumArgsObjCmd, 574 (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); 575 Tcl_CreateObjCommand(interp, "testfilesystem", TestFilesystemObjCmd, 576 (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); 577 Tcl_CreateObjCommand(interp, "testsimplefilesystem", TestSimpleFilesystemObjCmd, 578 (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); 579 Tcl_CreateObjCommand(interp, "testgetindexfromobjstruct", 580 TestGetIndexFromObjStructObjCmd, (ClientData) 0, 581 (Tcl_CmdDeleteProc *) NULL); 582 Tcl_CreateCommand(interp, "testaccessproc", TestaccessprocCmd, (ClientData) 0, 583 (Tcl_CmdDeleteProc *) NULL); 584 Tcl_CreateCommand(interp, "testasync", TestasyncCmd, (ClientData) 0, 585 (Tcl_CmdDeleteProc *) NULL); 586 Tcl_CreateCommand(interp, "testchannel", TestChannelCmd, 587 (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); 588 Tcl_CreateCommand(interp, "testchannelevent", TestChannelEventCmd, 589 (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); 590 Tcl_CreateCommand(interp, "testcmdtoken", TestcmdtokenCmd, (ClientData) 0, 591 (Tcl_CmdDeleteProc *) NULL); 592 Tcl_CreateCommand(interp, "testcmdinfo", TestcmdinfoCmd, (ClientData) 0, 593 (Tcl_CmdDeleteProc *) NULL); 594 Tcl_CreateCommand(interp, "testcmdtrace", TestcmdtraceCmd, 595 (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); 596 Tcl_CreateCommand(interp, "testcreatecommand", TestcreatecommandCmd, 597 (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); 598 Tcl_CreateCommand(interp, "testdcall", TestdcallCmd, (ClientData) 0, 599 (Tcl_CmdDeleteProc *) NULL); 600 Tcl_CreateCommand(interp, "testdel", TestdelCmd, (ClientData) 0, 601 (Tcl_CmdDeleteProc *) NULL); 602 Tcl_CreateCommand(interp, "testdelassocdata", TestdelassocdataCmd, 603 (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); 604 Tcl_DStringInit(&dstring); 605 Tcl_CreateCommand(interp, "testdstring", TestdstringCmd, (ClientData) 0, 606 (Tcl_CmdDeleteProc *) NULL); 607 Tcl_CreateObjCommand(interp, "testencoding", TestencodingObjCmd, (ClientData) 0, 608 (Tcl_CmdDeleteProc *) NULL); 609 Tcl_CreateObjCommand(interp, "testevalex", TestevalexObjCmd, 610 (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); 611 Tcl_CreateObjCommand(interp, "testevalobjv", TestevalobjvObjCmd, 612 (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); 613 Tcl_CreateObjCommand( interp, "testevent", TesteventObjCmd, 614 (ClientData) 0, (Tcl_CmdDeleteProc*) NULL ); 615 Tcl_CreateCommand(interp, "testexithandler", TestexithandlerCmd, 616 (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); 617 Tcl_CreateCommand(interp, "testexprlong", TestexprlongCmd, 618 (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); 619 Tcl_CreateObjCommand(interp, "testexprlongobj", TestexprlongobjCmd, 620 (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); 621 Tcl_CreateObjCommand(interp, "testexprparser", TestexprparserObjCmd, 622 (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); 623 Tcl_CreateCommand(interp, "testexprstring", TestexprstringCmd, 624 (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); 625 Tcl_CreateCommand(interp, "testfevent", TestfeventCmd, (ClientData) 0, 626 (Tcl_CmdDeleteProc *) NULL); 627 Tcl_CreateObjCommand(interp, "testfilelink", TestfilelinkCmd, 628 (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); 629 Tcl_CreateObjCommand(interp, "testfile", TestfileCmd, 630 (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); 631 Tcl_CreateCommand(interp, "testgetassocdata", TestgetassocdataCmd, 632 (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); 633 Tcl_CreateCommand(interp, "testgetplatform", TestgetplatformCmd, 634 (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); 635 Tcl_CreateObjCommand(interp, "testgetvarfullname", 636 TestgetvarfullnameCmd, (ClientData) 0, 637 (Tcl_CmdDeleteProc *) NULL); 638 Tcl_CreateCommand(interp, "testinterpdelete", TestinterpdeleteCmd, 639 (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); 640 Tcl_CreateCommand(interp, "testlink", TestlinkCmd, (ClientData) 0, 641 (Tcl_CmdDeleteProc *) NULL); 642 Tcl_CreateObjCommand(interp, "testlocale", TestlocaleCmd, (ClientData) 0, 643 (Tcl_CmdDeleteProc *) NULL); 644 Tcl_CreateCommand(interp, "testopenfilechannelproc", 645 TestopenfilechannelprocCmd, (ClientData) 0, 646 (Tcl_CmdDeleteProc *) NULL); 647 Tcl_CreateCommand(interp, "testpanic", TestpanicCmd, (ClientData) 0, 648 (Tcl_CmdDeleteProc *) NULL); 649 Tcl_CreateObjCommand(interp, "testparser", TestparserObjCmd, 650 (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); 651 Tcl_CreateObjCommand(interp, "testparsevar", TestparsevarObjCmd, 652 (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); 653 Tcl_CreateObjCommand(interp, "testparsevarname", TestparsevarnameObjCmd, 654 (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); 655 Tcl_CreateObjCommand(interp, "testregexp", TestregexpObjCmd, 656 (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); 657 Tcl_CreateObjCommand(interp, "testsaveresult", TestsaveresultCmd, 658 (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); 659 Tcl_CreateCommand(interp, "testsetassocdata", TestsetassocdataCmd, 660 (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); 661 Tcl_CreateCommand(interp, "testsetnoerr", TestsetCmd, 662 (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); 663 Tcl_CreateCommand(interp, "testseterr", TestsetCmd, 664 (ClientData) TCL_LEAVE_ERR_MSG, (Tcl_CmdDeleteProc *) NULL); 665 Tcl_CreateCommand(interp, "testseterrorcode", TestseterrorcodeCmd, 666 (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); 667 Tcl_CreateObjCommand(interp, "testsetobjerrorcode", 668 TestsetobjerrorcodeCmd, (ClientData) 0, 669 (Tcl_CmdDeleteProc *) NULL); 670 Tcl_CreateObjCommand(interp, "testnumutfchars", 671 TestNumUtfCharsCmd, (ClientData) 0, 672 (Tcl_CmdDeleteProc *) NULL); 673 Tcl_CreateCommand(interp, "testsetplatform", TestsetplatformCmd, 674 (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); 675 Tcl_CreateCommand(interp, "teststaticpkg", TeststaticpkgCmd, 676 (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); 677 Tcl_CreateCommand(interp, "testtranslatefilename", 678 TesttranslatefilenameCmd, (ClientData) 0, 679 (Tcl_CmdDeleteProc *) NULL); 680 Tcl_CreateCommand(interp, "testupvar", TestupvarCmd, (ClientData) 0, 681 (Tcl_CmdDeleteProc *) NULL); 682 Tcl_CreateMathFunc(interp, "T1", 0, (Tcl_ValueType *) NULL, TestMathFunc, 683 (ClientData) 123); 684 Tcl_CreateMathFunc(interp, "T2", 0, (Tcl_ValueType *) NULL, TestMathFunc, 685 (ClientData) 345); 686 Tcl_CreateCommand(interp, "teststatproc", TeststatprocCmd, (ClientData) 0, 687 (Tcl_CmdDeleteProc *) NULL); 688 Tcl_CreateCommand(interp, "testmainthread", TestmainthreadCmd, (ClientData) 0, 689 (Tcl_CmdDeleteProc *) NULL); 690 Tcl_CreateCommand(interp, "testsetmainloop", TestsetmainloopCmd, 691 (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL); 692 Tcl_CreateCommand(interp, "testexitmainloop", TestexitmainloopCmd, 693 (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL); 694 t3ArgTypes[0] = TCL_EITHER; 695 t3ArgTypes[1] = TCL_EITHER; 696 Tcl_CreateMathFunc(interp, "T3", 2, t3ArgTypes, TestMathFunc2, 697 (ClientData) 0); 698 699#ifdef TCL_THREADS 700 if (TclThread_Init(interp) != TCL_OK) { 701 return TCL_ERROR; 702 } 703#endif 704 705 /* 706 * Check for special options used in ../tests/main.test 707 */ 708 709 listPtr = Tcl_GetVar2Ex(interp, "argv", NULL, TCL_GLOBAL_ONLY); 710 if (listPtr != NULL) { 711 if (Tcl_ListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) { 712 return TCL_ERROR; 713 } 714 if (objc && (Tcl_GetIndexFromObj(NULL, objv[0], specialOptions, NULL, 715 TCL_EXACT, &index) == TCL_OK)) { 716 switch (index) { 717 case 0: { 718 return TCL_ERROR; 719 } 720 case 1: { 721 Tcl_DeleteInterp(interp); 722 return TCL_ERROR; 723 } 724 case 2: { 725 int mode; 726 Tcl_UnregisterChannel(interp, 727 Tcl_GetChannel(interp, "stderr", &mode)); 728 return TCL_ERROR; 729 } 730 case 3: { 731 if (objc-1) { 732 Tcl_SetVar2Ex(interp, "tcl_rcFileName", NULL, 733 objv[1], TCL_GLOBAL_ONLY); 734 } 735 return TCL_ERROR; 736 } 737 } 738 } 739 } 740 741 /* 742 * And finally add any platform specific test commands. 743 */ 744 745 return TclplatformtestInit(interp); 746} 747 748/* 749 *---------------------------------------------------------------------- 750 * 751 * TestasyncCmd -- 752 * 753 * This procedure implements the "testasync" command. It is used 754 * to test the asynchronous handler facilities of Tcl. 755 * 756 * Results: 757 * A standard Tcl result. 758 * 759 * Side effects: 760 * Creates, deletes, and invokes handlers. 761 * 762 *---------------------------------------------------------------------- 763 */ 764 765 /* ARGSUSED */ 766static int 767TestasyncCmd(dummy, interp, argc, argv) 768 ClientData dummy; /* Not used. */ 769 Tcl_Interp *interp; /* Current interpreter. */ 770 int argc; /* Number of arguments. */ 771 CONST char **argv; /* Argument strings. */ 772{ 773 TestAsyncHandler *asyncPtr, *prevPtr; 774 int id, code; 775 static int nextId = 1; 776 char buf[TCL_INTEGER_SPACE]; 777 778 if (argc < 2) { 779 wrongNumArgs: 780 Tcl_SetResult(interp, "wrong # args", TCL_STATIC); 781 return TCL_ERROR; 782 } 783 if (strcmp(argv[1], "create") == 0) { 784 if (argc != 3) { 785 goto wrongNumArgs; 786 } 787 asyncPtr = (TestAsyncHandler *) ckalloc(sizeof(TestAsyncHandler)); 788 asyncPtr->id = nextId; 789 nextId++; 790 asyncPtr->handler = Tcl_AsyncCreate(AsyncHandlerProc, 791 (ClientData) asyncPtr); 792 asyncPtr->command = (char *) ckalloc((unsigned) (strlen(argv[2]) + 1)); 793 strcpy(asyncPtr->command, argv[2]); 794 asyncPtr->nextPtr = firstHandler; 795 firstHandler = asyncPtr; 796 TclFormatInt(buf, asyncPtr->id); 797 Tcl_SetResult(interp, buf, TCL_VOLATILE); 798 } else if (strcmp(argv[1], "delete") == 0) { 799 if (argc == 2) { 800 while (firstHandler != NULL) { 801 asyncPtr = firstHandler; 802 firstHandler = asyncPtr->nextPtr; 803 Tcl_AsyncDelete(asyncPtr->handler); 804 ckfree(asyncPtr->command); 805 ckfree((char *) asyncPtr); 806 } 807 return TCL_OK; 808 } 809 if (argc != 3) { 810 goto wrongNumArgs; 811 } 812 if (Tcl_GetInt(interp, argv[2], &id) != TCL_OK) { 813 return TCL_ERROR; 814 } 815 for (prevPtr = NULL, asyncPtr = firstHandler; asyncPtr != NULL; 816 prevPtr = asyncPtr, asyncPtr = asyncPtr->nextPtr) { 817 if (asyncPtr->id != id) { 818 continue; 819 } 820 if (prevPtr == NULL) { 821 firstHandler = asyncPtr->nextPtr; 822 } else { 823 prevPtr->nextPtr = asyncPtr->nextPtr; 824 } 825 Tcl_AsyncDelete(asyncPtr->handler); 826 ckfree(asyncPtr->command); 827 ckfree((char *) asyncPtr); 828 break; 829 } 830 } else if (strcmp(argv[1], "mark") == 0) { 831 if (argc != 5) { 832 goto wrongNumArgs; 833 } 834 if ((Tcl_GetInt(interp, argv[2], &id) != TCL_OK) 835 || (Tcl_GetInt(interp, argv[4], &code) != TCL_OK)) { 836 return TCL_ERROR; 837 } 838 for (asyncPtr = firstHandler; asyncPtr != NULL; 839 asyncPtr = asyncPtr->nextPtr) { 840 if (asyncPtr->id == id) { 841 Tcl_AsyncMark(asyncPtr->handler); 842 break; 843 } 844 } 845 Tcl_SetResult(interp, (char *)argv[3], TCL_VOLATILE); 846 return code; 847 } else { 848 Tcl_AppendResult(interp, "bad option \"", argv[1], 849 "\": must be create, delete, int, or mark", 850 (char *) NULL); 851 return TCL_ERROR; 852 } 853 return TCL_OK; 854} 855 856static int 857AsyncHandlerProc(clientData, interp, code) 858 ClientData clientData; /* Pointer to TestAsyncHandler structure. */ 859 Tcl_Interp *interp; /* Interpreter in which command was 860 * executed, or NULL. */ 861 int code; /* Current return code from command. */ 862{ 863 TestAsyncHandler *asyncPtr = (TestAsyncHandler *) clientData; 864 CONST char *listArgv[4], *cmd; 865 char string[TCL_INTEGER_SPACE]; 866 867 TclFormatInt(string, code); 868 listArgv[0] = asyncPtr->command; 869 listArgv[1] = Tcl_GetString(Tcl_GetObjResult(interp)); 870 listArgv[2] = string; 871 listArgv[3] = NULL; 872 cmd = Tcl_Merge(3, listArgv); 873 if (interp != NULL) { 874 code = Tcl_Eval(interp, cmd); 875 } else { 876 /* 877 * this should not happen, but by definition of how async 878 * handlers are invoked, it's possible. Better error 879 * checking is needed here. 880 */ 881 } 882 ckfree((char *)cmd); 883 return code; 884} 885 886/* 887 *---------------------------------------------------------------------- 888 * 889 * TestcmdinfoCmd -- 890 * 891 * This procedure implements the "testcmdinfo" command. It is used 892 * to test Tcl_GetCommandInfo, Tcl_SetCommandInfo, and command creation 893 * and deletion. 894 * 895 * Results: 896 * A standard Tcl result. 897 * 898 * Side effects: 899 * Creates and deletes various commands and modifies their data. 900 * 901 *---------------------------------------------------------------------- 902 */ 903 904 /* ARGSUSED */ 905static int 906TestcmdinfoCmd(dummy, interp, argc, argv) 907 ClientData dummy; /* Not used. */ 908 Tcl_Interp *interp; /* Current interpreter. */ 909 int argc; /* Number of arguments. */ 910 CONST char **argv; /* Argument strings. */ 911{ 912 Tcl_CmdInfo info; 913 914 if (argc != 3) { 915 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], 916 " option cmdName\"", (char *) NULL); 917 return TCL_ERROR; 918 } 919 if (strcmp(argv[1], "create") == 0) { 920 Tcl_CreateCommand(interp, argv[2], CmdProc1, (ClientData) "original", 921 CmdDelProc1); 922 } else if (strcmp(argv[1], "delete") == 0) { 923 Tcl_DStringInit(&delString); 924 Tcl_DeleteCommand(interp, argv[2]); 925 Tcl_DStringResult(interp, &delString); 926 } else if (strcmp(argv[1], "get") == 0) { 927 if (Tcl_GetCommandInfo(interp, argv[2], &info) ==0) { 928 Tcl_SetResult(interp, "??", TCL_STATIC); 929 return TCL_OK; 930 } 931 if (info.proc == CmdProc1) { 932 Tcl_AppendResult(interp, "CmdProc1", " ", 933 (char *) info.clientData, (char *) NULL); 934 } else if (info.proc == CmdProc2) { 935 Tcl_AppendResult(interp, "CmdProc2", " ", 936 (char *) info.clientData, (char *) NULL); 937 } else { 938 Tcl_AppendResult(interp, "unknown", (char *) NULL); 939 } 940 if (info.deleteProc == CmdDelProc1) { 941 Tcl_AppendResult(interp, " CmdDelProc1", " ", 942 (char *) info.deleteData, (char *) NULL); 943 } else if (info.deleteProc == CmdDelProc2) { 944 Tcl_AppendResult(interp, " CmdDelProc2", " ", 945 (char *) info.deleteData, (char *) NULL); 946 } else { 947 Tcl_AppendResult(interp, " unknown", (char *) NULL); 948 } 949 Tcl_AppendResult(interp, " ", info.namespacePtr->fullName, 950 (char *) NULL); 951 if (info.isNativeObjectProc) { 952 Tcl_AppendResult(interp, " nativeObjectProc", (char *) NULL); 953 } else { 954 Tcl_AppendResult(interp, " stringProc", (char *) NULL); 955 } 956 } else if (strcmp(argv[1], "modify") == 0) { 957 info.proc = CmdProc2; 958 info.clientData = (ClientData) "new_command_data"; 959 info.objProc = NULL; 960 info.objClientData = (ClientData) NULL; 961 info.deleteProc = CmdDelProc2; 962 info.deleteData = (ClientData) "new_delete_data"; 963 if (Tcl_SetCommandInfo(interp, argv[2], &info) == 0) { 964 Tcl_SetResult(interp, "0", TCL_STATIC); 965 } else { 966 Tcl_SetResult(interp, "1", TCL_STATIC); 967 } 968 } else { 969 Tcl_AppendResult(interp, "bad option \"", argv[1], 970 "\": must be create, delete, get, or modify", 971 (char *) NULL); 972 return TCL_ERROR; 973 } 974 return TCL_OK; 975} 976 977 /*ARGSUSED*/ 978static int 979CmdProc1(clientData, interp, argc, argv) 980 ClientData clientData; /* String to return. */ 981 Tcl_Interp *interp; /* Current interpreter. */ 982 int argc; /* Number of arguments. */ 983 CONST char **argv; /* Argument strings. */ 984{ 985 Tcl_AppendResult(interp, "CmdProc1 ", (char *) clientData, 986 (char *) NULL); 987 return TCL_OK; 988} 989 990 /*ARGSUSED*/ 991static int 992CmdProc2(clientData, interp, argc, argv) 993 ClientData clientData; /* String to return. */ 994 Tcl_Interp *interp; /* Current interpreter. */ 995 int argc; /* Number of arguments. */ 996 CONST char **argv; /* Argument strings. */ 997{ 998 Tcl_AppendResult(interp, "CmdProc2 ", (char *) clientData, 999 (char *) NULL); 1000 return TCL_OK; 1001} 1002 1003static void 1004CmdDelProc1(clientData) 1005 ClientData clientData; /* String to save. */ 1006{ 1007 Tcl_DStringInit(&delString); 1008 Tcl_DStringAppend(&delString, "CmdDelProc1 ", -1); 1009 Tcl_DStringAppend(&delString, (char *) clientData, -1); 1010} 1011 1012static void 1013CmdDelProc2(clientData) 1014 ClientData clientData; /* String to save. */ 1015{ 1016 Tcl_DStringInit(&delString); 1017 Tcl_DStringAppend(&delString, "CmdDelProc2 ", -1); 1018 Tcl_DStringAppend(&delString, (char *) clientData, -1); 1019} 1020 1021/* 1022 *---------------------------------------------------------------------- 1023 * 1024 * TestcmdtokenCmd -- 1025 * 1026 * This procedure implements the "testcmdtoken" command. It is used 1027 * to test Tcl_Command tokens and procedures such as 1028 * Tcl_GetCommandFullName. 1029 * 1030 * Results: 1031 * A standard Tcl result. 1032 * 1033 * Side effects: 1034 * Creates and deletes various commands and modifies their data. 1035 * 1036 *---------------------------------------------------------------------- 1037 */ 1038 1039 /* ARGSUSED */ 1040static int 1041TestcmdtokenCmd(dummy, interp, argc, argv) 1042 ClientData dummy; /* Not used. */ 1043 Tcl_Interp *interp; /* Current interpreter. */ 1044 int argc; /* Number of arguments. */ 1045 CONST char **argv; /* Argument strings. */ 1046{ 1047 Tcl_Command token; 1048 int *l; 1049 char buf[30]; 1050 1051 if (argc != 3) { 1052 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], 1053 " option arg\"", (char *) NULL); 1054 return TCL_ERROR; 1055 } 1056 if (strcmp(argv[1], "create") == 0) { 1057 token = Tcl_CreateCommand(interp, argv[2], CmdProc1, 1058 (ClientData) "original", (Tcl_CmdDeleteProc *) NULL); 1059 sprintf(buf, "%p", (VOID *)token); 1060 Tcl_SetResult(interp, buf, TCL_VOLATILE); 1061 } else if (strcmp(argv[1], "name") == 0) { 1062 Tcl_Obj *objPtr; 1063 1064 if (sscanf(argv[2], "%p", &l) != 1) { 1065 Tcl_AppendResult(interp, "bad command token \"", argv[2], 1066 "\"", (char *) NULL); 1067 return TCL_ERROR; 1068 } 1069 1070 objPtr = Tcl_NewObj(); 1071 Tcl_GetCommandFullName(interp, (Tcl_Command) l, objPtr); 1072 1073 Tcl_AppendElement(interp, 1074 Tcl_GetCommandName(interp, (Tcl_Command) l)); 1075 Tcl_AppendElement(interp, Tcl_GetString(objPtr)); 1076 Tcl_DecrRefCount(objPtr); 1077 } else { 1078 Tcl_AppendResult(interp, "bad option \"", argv[1], 1079 "\": must be create or name", (char *) NULL); 1080 return TCL_ERROR; 1081 } 1082 return TCL_OK; 1083} 1084 1085/* 1086 *---------------------------------------------------------------------- 1087 * 1088 * TestcmdtraceCmd -- 1089 * 1090 * This procedure implements the "testcmdtrace" command. It is used 1091 * to test Tcl_CreateTrace and Tcl_DeleteTrace. 1092 * 1093 * Results: 1094 * A standard Tcl result. 1095 * 1096 * Side effects: 1097 * Creates and deletes a command trace, and tests the invocation of 1098 * a procedure by the command trace. 1099 * 1100 *---------------------------------------------------------------------- 1101 */ 1102 1103 /* ARGSUSED */ 1104static int 1105TestcmdtraceCmd(dummy, interp, argc, argv) 1106 ClientData dummy; /* Not used. */ 1107 Tcl_Interp *interp; /* Current interpreter. */ 1108 int argc; /* Number of arguments. */ 1109 CONST char **argv; /* Argument strings. */ 1110{ 1111 Tcl_DString buffer; 1112 int result; 1113 1114 if (argc != 3) { 1115 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], 1116 " option script\"", (char *) NULL); 1117 return TCL_ERROR; 1118 } 1119 1120 if (strcmp(argv[1], "tracetest") == 0) { 1121 Tcl_DStringInit(&buffer); 1122 cmdTrace = Tcl_CreateTrace(interp, 50000, 1123 (Tcl_CmdTraceProc *) CmdTraceProc, (ClientData) &buffer); 1124 result = Tcl_Eval(interp, argv[2]); 1125 if (result == TCL_OK) { 1126 Tcl_ResetResult(interp); 1127 Tcl_AppendResult(interp, Tcl_DStringValue(&buffer), NULL); 1128 } 1129 Tcl_DeleteTrace(interp, cmdTrace); 1130 Tcl_DStringFree(&buffer); 1131 } else if (strcmp(argv[1], "deletetest") == 0) { 1132 /* 1133 * Create a command trace then eval a script to check whether it is 1134 * called. Note that this trace procedure removes itself as a 1135 * further check of the robustness of the trace proc calling code in 1136 * TclExecuteByteCode. 1137 */ 1138 1139 cmdTrace = Tcl_CreateTrace(interp, 50000, 1140 (Tcl_CmdTraceProc *) CmdTraceDeleteProc, (ClientData) NULL); 1141 Tcl_Eval(interp, argv[2]); 1142 } else if (strcmp(argv[1], "leveltest") == 0) { 1143 Interp *iPtr = (Interp *) interp; 1144 Tcl_DStringInit(&buffer); 1145 cmdTrace = Tcl_CreateTrace(interp, iPtr->numLevels + 4, 1146 (Tcl_CmdTraceProc *) CmdTraceProc, (ClientData) &buffer); 1147 result = Tcl_Eval(interp, argv[2]); 1148 if (result == TCL_OK) { 1149 Tcl_ResetResult(interp); 1150 Tcl_AppendResult(interp, Tcl_DStringValue(&buffer), NULL); 1151 } 1152 Tcl_DeleteTrace(interp, cmdTrace); 1153 Tcl_DStringFree(&buffer); 1154 } else if ( strcmp(argv[1], "resulttest" ) == 0 ) { 1155 /* Create an object-based trace, then eval a script. This is used 1156 * to test return codes other than TCL_OK from the trace engine. 1157 */ 1158 static int deleteCalled; 1159 deleteCalled = 0; 1160 cmdTrace = Tcl_CreateObjTrace( interp, 50000, 1161 TCL_ALLOW_INLINE_COMPILATION, 1162 ObjTraceProc, 1163 (ClientData) &deleteCalled, 1164 ObjTraceDeleteProc ); 1165 result = Tcl_Eval( interp, argv[ 2 ] ); 1166 Tcl_DeleteTrace( interp, cmdTrace ); 1167 if ( !deleteCalled ) { 1168 Tcl_SetResult( interp, "Delete wasn't called", TCL_STATIC ); 1169 return TCL_ERROR; 1170 } else { 1171 return result; 1172 } 1173 } else if ( strcmp(argv[1], "doubletest" ) == 0 ) { 1174 Tcl_Trace t1, t2; 1175 1176 Tcl_DStringInit(&buffer); 1177 t1 = Tcl_CreateTrace(interp, 1, 1178 (Tcl_CmdTraceProc *) CmdTraceProc, (ClientData) &buffer); 1179 t2 = Tcl_CreateTrace(interp, 50000, 1180 (Tcl_CmdTraceProc *) CmdTraceProc, (ClientData) &buffer); 1181 result = Tcl_Eval(interp, argv[2]); 1182 if (result == TCL_OK) { 1183 Tcl_ResetResult(interp); 1184 Tcl_AppendResult(interp, Tcl_DStringValue(&buffer), NULL); 1185 } 1186 Tcl_DeleteTrace(interp, t2); 1187 Tcl_DeleteTrace(interp, t1); 1188 Tcl_DStringFree(&buffer); 1189 } else { 1190 Tcl_AppendResult(interp, "bad option \"", argv[1], 1191 "\": must be tracetest, deletetest, doubletest or resulttest", 1192 (char *) NULL); 1193 return TCL_ERROR; 1194 } 1195 return TCL_OK; 1196} 1197 1198static void 1199CmdTraceProc(clientData, interp, level, command, cmdProc, cmdClientData, 1200 argc, argv) 1201 ClientData clientData; /* Pointer to buffer in which the 1202 * command and arguments are appended. 1203 * Accumulates test result. */ 1204 Tcl_Interp *interp; /* Current interpreter. */ 1205 int level; /* Current trace level. */ 1206 char *command; /* The command being traced (after 1207 * substitutions). */ 1208 Tcl_CmdProc *cmdProc; /* Points to command's command procedure. */ 1209 ClientData cmdClientData; /* Client data associated with command 1210 * procedure. */ 1211 int argc; /* Number of arguments. */ 1212 char **argv; /* Argument strings. */ 1213{ 1214 Tcl_DString *bufPtr = (Tcl_DString *) clientData; 1215 int i; 1216 1217 Tcl_DStringAppendElement(bufPtr, command); 1218 1219 Tcl_DStringStartSublist(bufPtr); 1220 for (i = 0; i < argc; i++) { 1221 Tcl_DStringAppendElement(bufPtr, argv[i]); 1222 } 1223 Tcl_DStringEndSublist(bufPtr); 1224} 1225 1226static void 1227CmdTraceDeleteProc(clientData, interp, level, command, cmdProc, 1228 cmdClientData, argc, argv) 1229 ClientData clientData; /* Unused. */ 1230 Tcl_Interp *interp; /* Current interpreter. */ 1231 int level; /* Current trace level. */ 1232 char *command; /* The command being traced (after 1233 * substitutions). */ 1234 Tcl_CmdProc *cmdProc; /* Points to command's command procedure. */ 1235 ClientData cmdClientData; /* Client data associated with command 1236 * procedure. */ 1237 int argc; /* Number of arguments. */ 1238 char **argv; /* Argument strings. */ 1239{ 1240 /* 1241 * Remove ourselves to test whether calling Tcl_DeleteTrace within 1242 * a trace callback causes the for loop in TclExecuteByteCode that 1243 * calls traces to reference freed memory. 1244 */ 1245 1246 Tcl_DeleteTrace(interp, cmdTrace); 1247} 1248 1249static int 1250ObjTraceProc( clientData, interp, level, command, token, objc, objv ) 1251 ClientData clientData; /* unused */ 1252 Tcl_Interp* interp; /* Tcl interpreter */ 1253 int level; /* Execution level */ 1254 CONST char* command; /* Command being executed */ 1255 Tcl_Command token; /* Command information */ 1256 int objc; /* Parameter count */ 1257 Tcl_Obj *CONST objv[]; /* Parameter list */ 1258{ 1259 CONST char* word = Tcl_GetString( objv[ 0 ] ); 1260 if ( !strcmp( word, "Error" ) ) { 1261 Tcl_SetObjResult( interp, Tcl_NewStringObj( command, -1 ) ); 1262 return TCL_ERROR; 1263 } else if ( !strcmp( word, "Break" ) ) { 1264 return TCL_BREAK; 1265 } else if ( !strcmp( word, "Continue" ) ) { 1266 return TCL_CONTINUE; 1267 } else if ( !strcmp( word, "Return" ) ) { 1268 return TCL_RETURN; 1269 } else if ( !strcmp( word, "OtherStatus" ) ) { 1270 return 6; 1271 } else { 1272 return TCL_OK; 1273 } 1274} 1275 1276static void 1277ObjTraceDeleteProc( clientData ) 1278 ClientData clientData; 1279{ 1280 int * intPtr = (int *) clientData; 1281 *intPtr = 1; /* Record that the trace was deleted */ 1282} 1283 1284/* 1285 *---------------------------------------------------------------------- 1286 * 1287 * TestcreatecommandCmd -- 1288 * 1289 * This procedure implements the "testcreatecommand" command. It is 1290 * used to test that the Tcl_CreateCommand creates a new command in 1291 * the namespace specified as part of its name, if any. It also 1292 * checks that the namespace code ignore single ":"s in the middle 1293 * or end of a command name. 1294 * 1295 * Results: 1296 * A standard Tcl result. 1297 * 1298 * Side effects: 1299 * Creates and deletes two commands ("test_ns_basic::createdcommand" 1300 * and "value:at:"). 1301 * 1302 *---------------------------------------------------------------------- 1303 */ 1304 1305static int 1306TestcreatecommandCmd(dummy, interp, argc, argv) 1307 ClientData dummy; /* Not used. */ 1308 Tcl_Interp *interp; /* Current interpreter. */ 1309 int argc; /* Number of arguments. */ 1310 CONST char **argv; /* Argument strings. */ 1311{ 1312 if (argc != 2) { 1313 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], 1314 " option\"", (char *) NULL); 1315 return TCL_ERROR; 1316 } 1317 if (strcmp(argv[1], "create") == 0) { 1318 Tcl_CreateCommand(interp, "test_ns_basic::createdcommand", 1319 CreatedCommandProc, (ClientData) NULL, 1320 (Tcl_CmdDeleteProc *) NULL); 1321 } else if (strcmp(argv[1], "delete") == 0) { 1322 Tcl_DeleteCommand(interp, "test_ns_basic::createdcommand"); 1323 } else if (strcmp(argv[1], "create2") == 0) { 1324 Tcl_CreateCommand(interp, "value:at:", 1325 CreatedCommandProc2, (ClientData) NULL, 1326 (Tcl_CmdDeleteProc *) NULL); 1327 } else if (strcmp(argv[1], "delete2") == 0) { 1328 Tcl_DeleteCommand(interp, "value:at:"); 1329 } else { 1330 Tcl_AppendResult(interp, "bad option \"", argv[1], 1331 "\": must be create, delete, create2, or delete2", 1332 (char *) NULL); 1333 return TCL_ERROR; 1334 } 1335 return TCL_OK; 1336} 1337 1338static int 1339CreatedCommandProc(clientData, interp, argc, argv) 1340 ClientData clientData; /* String to return. */ 1341 Tcl_Interp *interp; /* Current interpreter. */ 1342 int argc; /* Number of arguments. */ 1343 CONST char **argv; /* Argument strings. */ 1344{ 1345 Tcl_CmdInfo info; 1346 int found; 1347 1348 found = Tcl_GetCommandInfo(interp, "test_ns_basic::createdcommand", 1349 &info); 1350 if (!found) { 1351 Tcl_AppendResult(interp, "CreatedCommandProc could not get command info for test_ns_basic::createdcommand", 1352 (char *) NULL); 1353 return TCL_ERROR; 1354 } 1355 Tcl_AppendResult(interp, "CreatedCommandProc in ", 1356 info.namespacePtr->fullName, (char *) NULL); 1357 return TCL_OK; 1358} 1359 1360static int 1361CreatedCommandProc2(clientData, interp, argc, argv) 1362 ClientData clientData; /* String to return. */ 1363 Tcl_Interp *interp; /* Current interpreter. */ 1364 int argc; /* Number of arguments. */ 1365 CONST char **argv; /* Argument strings. */ 1366{ 1367 Tcl_CmdInfo info; 1368 int found; 1369 1370 found = Tcl_GetCommandInfo(interp, "value:at:", &info); 1371 if (!found) { 1372 Tcl_AppendResult(interp, "CreatedCommandProc2 could not get command info for test_ns_basic::createdcommand", 1373 (char *) NULL); 1374 return TCL_ERROR; 1375 } 1376 Tcl_AppendResult(interp, "CreatedCommandProc2 in ", 1377 info.namespacePtr->fullName, (char *) NULL); 1378 return TCL_OK; 1379} 1380 1381/* 1382 *---------------------------------------------------------------------- 1383 * 1384 * TestdcallCmd -- 1385 * 1386 * This procedure implements the "testdcall" command. It is used 1387 * to test Tcl_CallWhenDeleted. 1388 * 1389 * Results: 1390 * A standard Tcl result. 1391 * 1392 * Side effects: 1393 * Creates and deletes interpreters. 1394 * 1395 *---------------------------------------------------------------------- 1396 */ 1397 1398 /* ARGSUSED */ 1399static int 1400TestdcallCmd(dummy, interp, argc, argv) 1401 ClientData dummy; /* Not used. */ 1402 Tcl_Interp *interp; /* Current interpreter. */ 1403 int argc; /* Number of arguments. */ 1404 CONST char **argv; /* Argument strings. */ 1405{ 1406 int i, id; 1407 1408 delInterp = Tcl_CreateInterp(); 1409 Tcl_DStringInit(&delString); 1410 for (i = 1; i < argc; i++) { 1411 if (Tcl_GetInt(interp, argv[i], &id) != TCL_OK) { 1412 return TCL_ERROR; 1413 } 1414 if (id < 0) { 1415 Tcl_DontCallWhenDeleted(delInterp, DelCallbackProc, 1416 (ClientData) (-id)); 1417 } else { 1418 Tcl_CallWhenDeleted(delInterp, DelCallbackProc, 1419 (ClientData) id); 1420 } 1421 } 1422 Tcl_DeleteInterp(delInterp); 1423 Tcl_DStringResult(interp, &delString); 1424 return TCL_OK; 1425} 1426 1427/* 1428 * The deletion callback used by TestdcallCmd: 1429 */ 1430 1431static void 1432DelCallbackProc(clientData, interp) 1433 ClientData clientData; /* Numerical value to append to 1434 * delString. */ 1435 Tcl_Interp *interp; /* Interpreter being deleted. */ 1436{ 1437 int id = (int) clientData; 1438 char buffer[TCL_INTEGER_SPACE]; 1439 1440 TclFormatInt(buffer, id); 1441 Tcl_DStringAppendElement(&delString, buffer); 1442 if (interp != delInterp) { 1443 Tcl_DStringAppendElement(&delString, "bogus interpreter argument!"); 1444 } 1445} 1446 1447/* 1448 *---------------------------------------------------------------------- 1449 * 1450 * TestdelCmd -- 1451 * 1452 * This procedure implements the "testdcall" command. It is used 1453 * to test Tcl_CallWhenDeleted. 1454 * 1455 * Results: 1456 * A standard Tcl result. 1457 * 1458 * Side effects: 1459 * Creates and deletes interpreters. 1460 * 1461 *---------------------------------------------------------------------- 1462 */ 1463 1464 /* ARGSUSED */ 1465static int 1466TestdelCmd(dummy, interp, argc, argv) 1467 ClientData dummy; /* Not used. */ 1468 Tcl_Interp *interp; /* Current interpreter. */ 1469 int argc; /* Number of arguments. */ 1470 CONST char **argv; /* Argument strings. */ 1471{ 1472 DelCmd *dPtr; 1473 Tcl_Interp *slave; 1474 1475 if (argc != 4) { 1476 Tcl_SetResult(interp, "wrong # args", TCL_STATIC); 1477 return TCL_ERROR; 1478 } 1479 1480 slave = Tcl_GetSlave(interp, argv[1]); 1481 if (slave == NULL) { 1482 return TCL_ERROR; 1483 } 1484 1485 dPtr = (DelCmd *) ckalloc(sizeof(DelCmd)); 1486 dPtr->interp = interp; 1487 dPtr->deleteCmd = (char *) ckalloc((unsigned) (strlen(argv[3]) + 1)); 1488 strcpy(dPtr->deleteCmd, argv[3]); 1489 1490 Tcl_CreateCommand(slave, argv[2], DelCmdProc, (ClientData) dPtr, 1491 DelDeleteProc); 1492 return TCL_OK; 1493} 1494 1495static int 1496DelCmdProc(clientData, interp, argc, argv) 1497 ClientData clientData; /* String result to return. */ 1498 Tcl_Interp *interp; /* Current interpreter. */ 1499 int argc; /* Number of arguments. */ 1500 CONST char **argv; /* Argument strings. */ 1501{ 1502 DelCmd *dPtr = (DelCmd *) clientData; 1503 1504 Tcl_AppendResult(interp, dPtr->deleteCmd, (char *) NULL); 1505 ckfree(dPtr->deleteCmd); 1506 ckfree((char *) dPtr); 1507 return TCL_OK; 1508} 1509 1510static void 1511DelDeleteProc(clientData) 1512 ClientData clientData; /* String command to evaluate. */ 1513{ 1514 DelCmd *dPtr = (DelCmd *) clientData; 1515 1516 Tcl_Eval(dPtr->interp, dPtr->deleteCmd); 1517 Tcl_ResetResult(dPtr->interp); 1518 ckfree(dPtr->deleteCmd); 1519 ckfree((char *) dPtr); 1520} 1521 1522/* 1523 *---------------------------------------------------------------------- 1524 * 1525 * TestdelassocdataCmd -- 1526 * 1527 * This procedure implements the "testdelassocdata" command. It is used 1528 * to test Tcl_DeleteAssocData. 1529 * 1530 * Results: 1531 * A standard Tcl result. 1532 * 1533 * Side effects: 1534 * Deletes an association between a key and associated data from an 1535 * interpreter. 1536 * 1537 *---------------------------------------------------------------------- 1538 */ 1539 1540static int 1541TestdelassocdataCmd(clientData, interp, argc, argv) 1542 ClientData clientData; /* Not used. */ 1543 Tcl_Interp *interp; /* Current interpreter. */ 1544 int argc; /* Number of arguments. */ 1545 CONST char **argv; /* Argument strings. */ 1546{ 1547 if (argc != 2) { 1548 Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], 1549 " data_key\"", (char *) NULL); 1550 return TCL_ERROR; 1551 } 1552 Tcl_DeleteAssocData(interp, argv[1]); 1553 return TCL_OK; 1554} 1555 1556/* 1557 *---------------------------------------------------------------------- 1558 * 1559 * TestdstringCmd -- 1560 * 1561 * This procedure implements the "testdstring" command. It is used 1562 * to test the dynamic string facilities of Tcl. 1563 * 1564 * Results: 1565 * A standard Tcl result. 1566 * 1567 * Side effects: 1568 * Creates, deletes, and invokes handlers. 1569 * 1570 *---------------------------------------------------------------------- 1571 */ 1572 1573 /* ARGSUSED */ 1574static int 1575TestdstringCmd(dummy, interp, argc, argv) 1576 ClientData dummy; /* Not used. */ 1577 Tcl_Interp *interp; /* Current interpreter. */ 1578 int argc; /* Number of arguments. */ 1579 CONST char **argv; /* Argument strings. */ 1580{ 1581 int count; 1582 1583 if (argc < 2) { 1584 wrongNumArgs: 1585 Tcl_SetResult(interp, "wrong # args", TCL_STATIC); 1586 return TCL_ERROR; 1587 } 1588 if (strcmp(argv[1], "append") == 0) { 1589 if (argc != 4) { 1590 goto wrongNumArgs; 1591 } 1592 if (Tcl_GetInt(interp, argv[3], &count) != TCL_OK) { 1593 return TCL_ERROR; 1594 } 1595 Tcl_DStringAppend(&dstring, argv[2], count); 1596 } else if (strcmp(argv[1], "element") == 0) { 1597 if (argc != 3) { 1598 goto wrongNumArgs; 1599 } 1600 Tcl_DStringAppendElement(&dstring, argv[2]); 1601 } else if (strcmp(argv[1], "end") == 0) { 1602 if (argc != 2) { 1603 goto wrongNumArgs; 1604 } 1605 Tcl_DStringEndSublist(&dstring); 1606 } else if (strcmp(argv[1], "free") == 0) { 1607 if (argc != 2) { 1608 goto wrongNumArgs; 1609 } 1610 Tcl_DStringFree(&dstring); 1611 } else if (strcmp(argv[1], "get") == 0) { 1612 if (argc != 2) { 1613 goto wrongNumArgs; 1614 } 1615 Tcl_SetResult(interp, Tcl_DStringValue(&dstring), TCL_VOLATILE); 1616 } else if (strcmp(argv[1], "gresult") == 0) { 1617 if (argc != 3) { 1618 goto wrongNumArgs; 1619 } 1620 if (strcmp(argv[2], "staticsmall") == 0) { 1621 Tcl_SetResult(interp, "short", TCL_STATIC); 1622 } else if (strcmp(argv[2], "staticlarge") == 0) { 1623 Tcl_SetResult(interp, "first0 first1 first2 first3 first4 first5 first6 first7 first8 first9\nsecond0 second1 second2 second3 second4 second5 second6 second7 second8 second9\nthird0 third1 third2 third3 third4 third5 third6 third7 third8 third9\nfourth0 fourth1 fourth2 fourth3 fourth4 fourth5 fourth6 fourth7 fourth8 fourth9\nfifth0 fifth1 fifth2 fifth3 fifth4 fifth5 fifth6 fifth7 fifth8 fifth9\nsixth0 sixth1 sixth2 sixth3 sixth4 sixth5 sixth6 sixth7 sixth8 sixth9\nseventh0 seventh1 seventh2 seventh3 seventh4 seventh5 seventh6 seventh7 seventh8 seventh9\n", TCL_STATIC); 1624 } else if (strcmp(argv[2], "free") == 0) { 1625 Tcl_SetResult(interp, (char *) ckalloc(100), TCL_DYNAMIC); 1626 strcpy(interp->result, "This is a malloc-ed string"); 1627 } else if (strcmp(argv[2], "special") == 0) { 1628 interp->result = (char *) ckalloc(100); 1629 interp->result += 4; 1630 interp->freeProc = SpecialFree; 1631 strcpy(interp->result, "This is a specially-allocated string"); 1632 } else { 1633 Tcl_AppendResult(interp, "bad gresult option \"", argv[2], 1634 "\": must be staticsmall, staticlarge, free, or special", 1635 (char *) NULL); 1636 return TCL_ERROR; 1637 } 1638 Tcl_DStringGetResult(interp, &dstring); 1639 } else if (strcmp(argv[1], "length") == 0) { 1640 char buf[TCL_INTEGER_SPACE]; 1641 1642 if (argc != 2) { 1643 goto wrongNumArgs; 1644 } 1645 TclFormatInt(buf, Tcl_DStringLength(&dstring)); 1646 Tcl_SetResult(interp, buf, TCL_VOLATILE); 1647 } else if (strcmp(argv[1], "result") == 0) { 1648 if (argc != 2) { 1649 goto wrongNumArgs; 1650 } 1651 Tcl_DStringResult(interp, &dstring); 1652 } else if (strcmp(argv[1], "trunc") == 0) { 1653 if (argc != 3) { 1654 goto wrongNumArgs; 1655 } 1656 if (Tcl_GetInt(interp, argv[2], &count) != TCL_OK) { 1657 return TCL_ERROR; 1658 } 1659 Tcl_DStringTrunc(&dstring, count); 1660 } else if (strcmp(argv[1], "start") == 0) { 1661 if (argc != 2) { 1662 goto wrongNumArgs; 1663 } 1664 Tcl_DStringStartSublist(&dstring); 1665 } else { 1666 Tcl_AppendResult(interp, "bad option \"", argv[1], 1667 "\": must be append, element, end, free, get, length, ", 1668 "result, trunc, or start", (char *) NULL); 1669 return TCL_ERROR; 1670 } 1671 return TCL_OK; 1672} 1673 1674/* 1675 * The procedure below is used as a special freeProc to test how well 1676 * Tcl_DStringGetResult handles freeProc's other than free. 1677 */ 1678 1679static void SpecialFree(blockPtr) 1680 char *blockPtr; /* Block to free. */ 1681{ 1682 ckfree(blockPtr - 4); 1683} 1684 1685/* 1686 *---------------------------------------------------------------------- 1687 * 1688 * TestencodingCmd -- 1689 * 1690 * This procedure implements the "testencoding" command. It is used 1691 * to test the encoding package. 1692 * 1693 * Results: 1694 * A standard Tcl result. 1695 * 1696 * Side effects: 1697 * Load encodings. 1698 * 1699 *---------------------------------------------------------------------- 1700 */ 1701 1702 /* ARGSUSED */ 1703static int 1704TestencodingObjCmd(dummy, interp, objc, objv) 1705 ClientData dummy; /* Not used. */ 1706 Tcl_Interp *interp; /* Current interpreter. */ 1707 int objc; /* Number of arguments. */ 1708 Tcl_Obj *CONST objv[]; /* Argument objects. */ 1709{ 1710 Tcl_Encoding encoding; 1711 int index, length; 1712 char *string; 1713 TclEncoding *encodingPtr; 1714 static CONST char *optionStrings[] = { 1715 "create", "delete", "path", 1716 NULL 1717 }; 1718 enum options { 1719 ENC_CREATE, ENC_DELETE, ENC_PATH 1720 }; 1721 1722 if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0, 1723 &index) != TCL_OK) { 1724 return TCL_ERROR; 1725 } 1726 1727 switch ((enum options) index) { 1728 case ENC_CREATE: { 1729 Tcl_EncodingType type; 1730 1731 if (objc != 5) { 1732 return TCL_ERROR; 1733 } 1734 encodingPtr = (TclEncoding *) ckalloc(sizeof(TclEncoding)); 1735 encodingPtr->interp = interp; 1736 1737 string = Tcl_GetStringFromObj(objv[3], &length); 1738 encodingPtr->toUtfCmd = (char *) ckalloc((unsigned) (length + 1)); 1739 memcpy(encodingPtr->toUtfCmd, string, (unsigned) length + 1); 1740 1741 string = Tcl_GetStringFromObj(objv[4], &length); 1742 encodingPtr->fromUtfCmd = (char *) ckalloc((unsigned) (length + 1)); 1743 memcpy(encodingPtr->fromUtfCmd, string, (unsigned) (length + 1)); 1744 1745 string = Tcl_GetStringFromObj(objv[2], &length); 1746 1747 type.encodingName = string; 1748 type.toUtfProc = EncodingToUtfProc; 1749 type.fromUtfProc = EncodingFromUtfProc; 1750 type.freeProc = EncodingFreeProc; 1751 type.clientData = (ClientData) encodingPtr; 1752 type.nullSize = 1; 1753 1754 Tcl_CreateEncoding(&type); 1755 break; 1756 } 1757 case ENC_DELETE: { 1758 if (objc != 3) { 1759 return TCL_ERROR; 1760 } 1761 encoding = Tcl_GetEncoding(NULL, Tcl_GetString(objv[2])); 1762 Tcl_FreeEncoding(encoding); 1763 Tcl_FreeEncoding(encoding); 1764 break; 1765 } 1766 case ENC_PATH: { 1767 if (objc == 2) { 1768 Tcl_SetObjResult(interp, TclGetLibraryPath()); 1769 } else { 1770 TclSetLibraryPath(objv[2]); 1771 } 1772 break; 1773 } 1774 } 1775 return TCL_OK; 1776} 1777static int 1778EncodingToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, 1779 srcReadPtr, dstWrotePtr, dstCharsPtr) 1780 ClientData clientData; /* TclEncoding structure. */ 1781 CONST char *src; /* Source string in specified encoding. */ 1782 int srcLen; /* Source string length in bytes. */ 1783 int flags; /* Conversion control flags. */ 1784 Tcl_EncodingState *statePtr;/* Current state. */ 1785 char *dst; /* Output buffer. */ 1786 int dstLen; /* The maximum length of output buffer. */ 1787 int *srcReadPtr; /* Filled with number of bytes read. */ 1788 int *dstWrotePtr; /* Filled with number of bytes stored. */ 1789 int *dstCharsPtr; /* Filled with number of chars stored. */ 1790{ 1791 int len; 1792 TclEncoding *encodingPtr; 1793 1794 encodingPtr = (TclEncoding *) clientData; 1795 Tcl_GlobalEval(encodingPtr->interp, encodingPtr->toUtfCmd); 1796 1797 len = strlen(Tcl_GetStringResult(encodingPtr->interp)); 1798 if (len > dstLen) { 1799 len = dstLen; 1800 } 1801 memcpy(dst, Tcl_GetStringResult(encodingPtr->interp), (unsigned) len); 1802 Tcl_ResetResult(encodingPtr->interp); 1803 1804 *srcReadPtr = srcLen; 1805 *dstWrotePtr = len; 1806 *dstCharsPtr = len; 1807 return TCL_OK; 1808} 1809static int 1810EncodingFromUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, 1811 srcReadPtr, dstWrotePtr, dstCharsPtr) 1812 ClientData clientData; /* TclEncoding structure. */ 1813 CONST char *src; /* Source string in specified encoding. */ 1814 int srcLen; /* Source string length in bytes. */ 1815 int flags; /* Conversion control flags. */ 1816 Tcl_EncodingState *statePtr;/* Current state. */ 1817 char *dst; /* Output buffer. */ 1818 int dstLen; /* The maximum length of output buffer. */ 1819 int *srcReadPtr; /* Filled with number of bytes read. */ 1820 int *dstWrotePtr; /* Filled with number of bytes stored. */ 1821 int *dstCharsPtr; /* Filled with number of chars stored. */ 1822{ 1823 int len; 1824 TclEncoding *encodingPtr; 1825 1826 encodingPtr = (TclEncoding *) clientData; 1827 Tcl_GlobalEval(encodingPtr->interp, encodingPtr->fromUtfCmd); 1828 1829 len = strlen(Tcl_GetStringResult(encodingPtr->interp)); 1830 if (len > dstLen) { 1831 len = dstLen; 1832 } 1833 memcpy(dst, Tcl_GetStringResult(encodingPtr->interp), (unsigned) len); 1834 Tcl_ResetResult(encodingPtr->interp); 1835 1836 *srcReadPtr = srcLen; 1837 *dstWrotePtr = len; 1838 *dstCharsPtr = len; 1839 return TCL_OK; 1840} 1841static void 1842EncodingFreeProc(clientData) 1843 ClientData clientData; /* ClientData associated with type. */ 1844{ 1845 TclEncoding *encodingPtr; 1846 1847 encodingPtr = (TclEncoding *) clientData; 1848 ckfree((char *) encodingPtr->toUtfCmd); 1849 ckfree((char *) encodingPtr->fromUtfCmd); 1850 ckfree((char *) encodingPtr); 1851} 1852 1853/* 1854 *---------------------------------------------------------------------- 1855 * 1856 * TestevalexObjCmd -- 1857 * 1858 * This procedure implements the "testevalex" command. It is 1859 * used to test Tcl_EvalEx. 1860 * 1861 * Results: 1862 * A standard Tcl result. 1863 * 1864 * Side effects: 1865 * None. 1866 * 1867 *---------------------------------------------------------------------- 1868 */ 1869 1870static int 1871TestevalexObjCmd(dummy, interp, objc, objv) 1872 ClientData dummy; /* Not used. */ 1873 Tcl_Interp *interp; /* Current interpreter. */ 1874 int objc; /* Number of arguments. */ 1875 Tcl_Obj *CONST objv[]; /* Argument objects. */ 1876{ 1877 Interp *iPtr = (Interp *) interp; 1878 int code, oldFlags, length, flags; 1879 char *string; 1880 1881 if (objc == 1) { 1882 /* 1883 * The command was invoked with no arguments, so just toggle 1884 * the flag that determines whether we use Tcl_EvalEx. 1885 */ 1886 1887 if (iPtr->flags & USE_EVAL_DIRECT) { 1888 iPtr->flags &= ~USE_EVAL_DIRECT; 1889 Tcl_SetResult(interp, "disabling direct evaluation", TCL_STATIC); 1890 } else { 1891 iPtr->flags |= USE_EVAL_DIRECT; 1892 Tcl_SetResult(interp, "enabling direct evaluation", TCL_STATIC); 1893 } 1894 return TCL_OK; 1895 } 1896 1897 flags = 0; 1898 if (objc == 3) { 1899 string = Tcl_GetStringFromObj(objv[2], &length); 1900 if (strcmp(string, "global") != 0) { 1901 Tcl_AppendResult(interp, "bad value \"", string, 1902 "\": must be global", (char *) NULL); 1903 return TCL_ERROR; 1904 } 1905 flags = TCL_EVAL_GLOBAL; 1906 } else if (objc != 2) { 1907 Tcl_WrongNumArgs(interp, 1, objv, "script ?global?"); 1908 return TCL_ERROR; 1909 } 1910 Tcl_SetResult(interp, "xxx", TCL_STATIC); 1911 1912 /* 1913 * Note, we have to set the USE_EVAL_DIRECT flag in the interpreter 1914 * in addition to calling Tcl_EvalEx. This is needed so that even nested 1915 * commands are evaluated directly. 1916 */ 1917 1918 oldFlags = iPtr->flags; 1919 iPtr->flags |= USE_EVAL_DIRECT; 1920 string = Tcl_GetStringFromObj(objv[1], &length); 1921 code = Tcl_EvalEx(interp, string, length, flags); 1922 iPtr->flags = (iPtr->flags & ~USE_EVAL_DIRECT) 1923 | (oldFlags & USE_EVAL_DIRECT); 1924 return code; 1925} 1926 1927/* 1928 *---------------------------------------------------------------------- 1929 * 1930 * TestevalobjvObjCmd -- 1931 * 1932 * This procedure implements the "testevalobjv" command. It is 1933 * used to test Tcl_EvalObjv. 1934 * 1935 * Results: 1936 * A standard Tcl result. 1937 * 1938 * Side effects: 1939 * None. 1940 * 1941 *---------------------------------------------------------------------- 1942 */ 1943 1944static int 1945TestevalobjvObjCmd(dummy, interp, objc, objv) 1946 ClientData dummy; /* Not used. */ 1947 Tcl_Interp *interp; /* Current interpreter. */ 1948 int objc; /* Number of arguments. */ 1949 Tcl_Obj *CONST objv[]; /* Argument objects. */ 1950{ 1951 int evalGlobal; 1952 1953 if (objc < 3) { 1954 Tcl_WrongNumArgs(interp, 1, objv, "global word ?word ...?"); 1955 return TCL_ERROR; 1956 } 1957 if (Tcl_GetIntFromObj(interp, objv[1], &evalGlobal) != TCL_OK) { 1958 return TCL_ERROR; 1959 } 1960 return Tcl_EvalObjv(interp, objc-2, objv+2, 1961 (evalGlobal) ? TCL_EVAL_GLOBAL : 0); 1962} 1963 1964/* 1965 *---------------------------------------------------------------------- 1966 * 1967 * TesteventObjCmd -- 1968 * 1969 * This procedure implements a 'testevent' command. The command 1970 * is used to test event queue management. 1971 * 1972 * The command takes two forms: 1973 * - testevent queue name position script 1974 * Queues an event at the given position in the queue, and 1975 * associates a given name with it (the same name may be 1976 * associated with multiple events). When the event comes 1977 * to the head of the queue, executes the given script at 1978 * global level in the current interp. The position may be 1979 * one of 'head', 'tail' or 'mark'. 1980 * - testevent delete name 1981 * Deletes any events associated with the given name from 1982 * the queue. 1983 * 1984 * Return value: 1985 * Returns a standard Tcl result. 1986 * 1987 * Side effects: 1988 * Manipulates the event queue as directed. 1989 * 1990 *---------------------------------------------------------------------- 1991 */ 1992 1993static int 1994TesteventObjCmd( ClientData unused, /* Not used */ 1995 Tcl_Interp* interp, /* Tcl interpreter */ 1996 int objc, /* Parameter count */ 1997 Tcl_Obj *CONST objv[] ) /* Parameter vector */ 1998{ 1999 2000 static CONST char* subcommands[] = { /* Possible subcommands */ 2001 "queue", 2002 "delete", 2003 NULL 2004 }; 2005 int subCmdIndex; /* Index of the chosen subcommand */ 2006 static CONST char* positions[] = { /* Possible queue positions */ 2007 "head", 2008 "tail", 2009 "mark", 2010 NULL 2011 }; 2012 int posIndex; /* Index of the chosen position */ 2013 static CONST Tcl_QueuePosition posNum[] = { 2014 /* Interpretation of the chosen position */ 2015 TCL_QUEUE_HEAD, 2016 TCL_QUEUE_TAIL, 2017 TCL_QUEUE_MARK 2018 }; 2019 TestEvent* ev; /* Event to be queued */ 2020 2021 if ( objc < 2 ) { 2022 Tcl_WrongNumArgs( interp, 1, objv, "subcommand ?args?" ); 2023 return TCL_ERROR; 2024 } 2025 if ( Tcl_GetIndexFromObj( interp, objv[1], subcommands, "subcommand", 2026 TCL_EXACT, &subCmdIndex ) != TCL_OK ) { 2027 return TCL_ERROR; 2028 } 2029 switch ( subCmdIndex ) { 2030 case 0: /* queue */ 2031 if ( objc != 5 ) { 2032 Tcl_WrongNumArgs( interp, 2, objv, "name position script" ); 2033 return TCL_ERROR; 2034 } 2035 if ( Tcl_GetIndexFromObj( interp, objv[3], positions, 2036 "position specifier", TCL_EXACT, 2037 &posIndex ) != TCL_OK ) { 2038 return TCL_ERROR; 2039 } 2040 ev = (TestEvent*) ckalloc( sizeof( TestEvent ) ); 2041 ev->header.proc = TesteventProc; 2042 ev->header.nextPtr = NULL; 2043 ev->interp = interp; 2044 ev->command = objv[ 4 ]; 2045 Tcl_IncrRefCount( ev->command ); 2046 ev->tag = objv[ 2 ]; 2047 Tcl_IncrRefCount( ev->tag ); 2048 Tcl_QueueEvent( (Tcl_Event*) ev, posNum[ posIndex ] ); 2049 break; 2050 2051 case 1: /* delete */ 2052 if ( objc != 3 ) { 2053 Tcl_WrongNumArgs( interp, 2, objv, "name" ); 2054 return TCL_ERROR; 2055 } 2056 Tcl_DeleteEvents( TesteventDeleteProc, objv[ 2 ] ); 2057 break; 2058 } 2059 2060 return TCL_OK; 2061 2062} 2063 2064/* 2065 *---------------------------------------------------------------------- 2066 * 2067 * TesteventProc -- 2068 * 2069 * Delivers a test event to the Tcl interpreter as part of event 2070 * queue testing. 2071 * 2072 * Results: 2073 * Returns 1 if the event has been serviced, 0 otherwise. 2074 * 2075 * Side effects: 2076 * Evaluates the event's callback script, so has whatever 2077 * side effects the callback has. The return value of the 2078 * callback script becomes the return value of this function. 2079 * If the callback script reports an error, it is reported as 2080 * a background error. 2081 * 2082 *---------------------------------------------------------------------- 2083 */ 2084 2085static int 2086TesteventProc( Tcl_Event* event, /* Event to deliver */ 2087 int flags ) /* Current flags for Tcl_ServiceEvent */ 2088{ 2089 TestEvent * ev = (TestEvent *) event; 2090 Tcl_Interp* interp = ev->interp; 2091 Tcl_Obj* command = ev->command; 2092 int result = Tcl_EvalObjEx( interp, command, 2093 TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT ); 2094 int retval; 2095 if ( result != TCL_OK ) { 2096 Tcl_AddErrorInfo( interp, 2097 " (command bound to \"testevent\" callback)" ); 2098 Tcl_BackgroundError( interp ); 2099 return 1; /* Avoid looping on errors */ 2100 } 2101 if ( Tcl_GetBooleanFromObj( interp, 2102 Tcl_GetObjResult( interp ), 2103 &retval ) != TCL_OK ) { 2104 Tcl_AddErrorInfo( interp, 2105 " (return value from \"testevent\" callback)" ); 2106 Tcl_BackgroundError( interp ); 2107 return 1; 2108 } 2109 if ( retval ) { 2110 Tcl_DecrRefCount( ev->tag ); 2111 Tcl_DecrRefCount( ev->command ); 2112 } 2113 2114 return retval; 2115} 2116 2117/* 2118 *---------------------------------------------------------------------- 2119 * 2120 * TesteventDeleteProc -- 2121 * 2122 * Removes some set of events from the queue. 2123 * 2124 * This procedure is used as part of testing event queue management. 2125 * 2126 * Results: 2127 * Returns 1 if a given event should be deleted, 0 otherwise. 2128 * 2129 * Side effects: 2130 * None. 2131 * 2132 *---------------------------------------------------------------------- 2133 */ 2134 2135static int 2136TesteventDeleteProc( Tcl_Event* event, /* Event to examine */ 2137 ClientData clientData ) /* Tcl_Obj containing the name 2138 * of the event(s) to remove */ 2139{ 2140 TestEvent* ev; /* Event to examine */ 2141 char* evNameStr; 2142 Tcl_Obj* targetName; /* Name of the event(s) to delete */ 2143 char* targetNameStr; 2144 2145 if ( event->proc != TesteventProc ) { 2146 return 0; 2147 } 2148 targetName = (Tcl_Obj*) clientData; 2149 targetNameStr = (char*) Tcl_GetStringFromObj( targetName, NULL ); 2150 ev = (TestEvent*) event; 2151 evNameStr = Tcl_GetStringFromObj( ev->tag, NULL ); 2152 if ( strcmp( evNameStr, targetNameStr ) == 0 ) { 2153 Tcl_DecrRefCount( ev->tag ); 2154 Tcl_DecrRefCount( ev->command ); 2155 return 1; 2156 } else { 2157 return 0; 2158 } 2159} 2160 2161/* 2162 *---------------------------------------------------------------------- 2163 * 2164 * TestexithandlerCmd -- 2165 * 2166 * This procedure implements the "testexithandler" command. It is 2167 * used to test Tcl_CreateExitHandler and Tcl_DeleteExitHandler. 2168 * 2169 * Results: 2170 * A standard Tcl result. 2171 * 2172 * Side effects: 2173 * None. 2174 * 2175 *---------------------------------------------------------------------- 2176 */ 2177 2178static int 2179TestexithandlerCmd(clientData, interp, argc, argv) 2180 ClientData clientData; /* Not used. */ 2181 Tcl_Interp *interp; /* Current interpreter. */ 2182 int argc; /* Number of arguments. */ 2183 CONST char **argv; /* Argument strings. */ 2184{ 2185 int value; 2186 2187 if (argc != 3) { 2188 Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], 2189 " create|delete value\"", (char *) NULL); 2190 return TCL_ERROR; 2191 } 2192 if (Tcl_GetInt(interp, argv[2], &value) != TCL_OK) { 2193 return TCL_ERROR; 2194 } 2195 if (strcmp(argv[1], "create") == 0) { 2196 Tcl_CreateExitHandler((value & 1) ? ExitProcOdd : ExitProcEven, 2197 (ClientData) value); 2198 } else if (strcmp(argv[1], "delete") == 0) { 2199 Tcl_DeleteExitHandler((value & 1) ? ExitProcOdd : ExitProcEven, 2200 (ClientData) value); 2201 } else { 2202 Tcl_AppendResult(interp, "bad option \"", argv[1], 2203 "\": must be create or delete", (char *) NULL); 2204 return TCL_ERROR; 2205 } 2206 return TCL_OK; 2207} 2208 2209static void 2210ExitProcOdd(clientData) 2211 ClientData clientData; /* Integer value to print. */ 2212{ 2213 char buf[16 + TCL_INTEGER_SPACE]; 2214 2215 sprintf(buf, "odd %d\n", (int) clientData); 2216 write(1, buf, strlen(buf)); 2217} 2218 2219static void 2220ExitProcEven(clientData) 2221 ClientData clientData; /* Integer value to print. */ 2222{ 2223 char buf[16 + TCL_INTEGER_SPACE]; 2224 2225 sprintf(buf, "even %d\n", (int) clientData); 2226 write(1, buf, strlen(buf)); 2227} 2228 2229/* 2230 *---------------------------------------------------------------------- 2231 * 2232 * TestexprlongCmd -- 2233 * 2234 * This procedure verifies that Tcl_ExprLong does not modify the 2235 * interpreter result if there is no error. 2236 * 2237 * Results: 2238 * A standard Tcl result. 2239 * 2240 * Side effects: 2241 * None. 2242 * 2243 *---------------------------------------------------------------------- 2244 */ 2245 2246static int 2247TestexprlongCmd(clientData, interp, argc, argv) 2248 ClientData clientData; /* Not used. */ 2249 Tcl_Interp *interp; /* Current interpreter. */ 2250 int argc; /* Number of arguments. */ 2251 CONST char **argv; /* Argument strings. */ 2252{ 2253 long exprResult; 2254 char buf[4 + TCL_INTEGER_SPACE]; 2255 int result; 2256 2257 Tcl_SetResult(interp, "This is a result", TCL_STATIC); 2258 result = Tcl_ExprLong(interp, "4+1", &exprResult); 2259 if (result != TCL_OK) { 2260 return result; 2261 } 2262 sprintf(buf, ": %ld", exprResult); 2263 Tcl_AppendResult(interp, buf, NULL); 2264 return TCL_OK; 2265} 2266 2267/* 2268 *---------------------------------------------------------------------- 2269 * 2270 * TestexprlongobjCmd -- 2271 * 2272 * This procedure verifies that Tcl_ExprLongObj does not modify the 2273 * interpreter result if there is no error. 2274 * 2275 * Results: 2276 * A standard Tcl result. 2277 * 2278 * Side effects: 2279 * None. 2280 * 2281 *---------------------------------------------------------------------- 2282 */ 2283 2284static int 2285TestexprlongobjCmd(clientData, interp, objc, objv) 2286 ClientData clientData; /* Not used. */ 2287 Tcl_Interp *interp; /* Current interpreter. */ 2288 int objc; /* Number of arguments. */ 2289 Tcl_Obj *CONST *objv; /* Argument objects. */ 2290{ 2291 long exprResult; 2292 char buf[4 + TCL_INTEGER_SPACE]; 2293 int result; 2294 2295 if (objc != 2) { 2296 Tcl_WrongNumArgs(interp, 1, objv, "expression"); 2297 return TCL_ERROR; 2298 } 2299 Tcl_SetResult(interp, "This is a result", TCL_STATIC); 2300 result = Tcl_ExprLongObj(interp, objv[1], &exprResult); 2301 if (result != TCL_OK) { 2302 return result; 2303 } 2304 sprintf(buf, ": %ld", exprResult); 2305 Tcl_AppendResult(interp, buf, NULL); 2306 return TCL_OK; 2307} 2308 2309/* 2310 *---------------------------------------------------------------------- 2311 * 2312 * TestexprstringCmd -- 2313 * 2314 * This procedure tests the basic operation of Tcl_ExprString. 2315 * 2316 * Results: 2317 * A standard Tcl result. 2318 * 2319 * Side effects: 2320 * None. 2321 * 2322 *---------------------------------------------------------------------- 2323 */ 2324 2325static int 2326TestexprstringCmd(clientData, interp, argc, argv) 2327 ClientData clientData; /* Not used. */ 2328 Tcl_Interp *interp; /* Current interpreter. */ 2329 int argc; /* Number of arguments. */ 2330 CONST char **argv; /* Argument strings. */ 2331{ 2332 if (argc != 2) { 2333 Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], 2334 " expression\"", (char *) NULL); 2335 return TCL_ERROR; 2336 } 2337 return Tcl_ExprString(interp, argv[1]); 2338} 2339 2340/* 2341 *---------------------------------------------------------------------- 2342 * 2343 * TestfilelinkCmd -- 2344 * 2345 * This procedure implements the "testfilelink" command. It is used 2346 * to test the effects of creating and manipulating filesystem links 2347 * in Tcl. 2348 * 2349 * Results: 2350 * A standard Tcl result. 2351 * 2352 * Side effects: 2353 * May create a link on disk. 2354 * 2355 *---------------------------------------------------------------------- 2356 */ 2357 2358static int 2359TestfilelinkCmd(clientData, interp, objc, objv) 2360 ClientData clientData; /* Not used. */ 2361 Tcl_Interp *interp; /* Current interpreter. */ 2362 int objc; /* Number of arguments. */ 2363 Tcl_Obj *CONST objv[]; /* The argument objects. */ 2364{ 2365 Tcl_Obj *contents; 2366 2367 if (objc < 2 || objc > 3) { 2368 Tcl_WrongNumArgs(interp, 1, objv, "source ?target?"); 2369 return TCL_ERROR; 2370 } 2371 2372 if (Tcl_FSConvertToPathType(interp, objv[1]) != TCL_OK) { 2373 return TCL_ERROR; 2374 } 2375 2376 if (objc == 3) { 2377 /* Create link from source to target */ 2378 contents = Tcl_FSLink(objv[1], objv[2], 2379 TCL_CREATE_SYMBOLIC_LINK|TCL_CREATE_HARD_LINK); 2380 if (contents == NULL) { 2381 Tcl_AppendResult(interp, "could not create link from \"", 2382 Tcl_GetString(objv[1]), "\" to \"", 2383 Tcl_GetString(objv[2]), "\": ", 2384 Tcl_PosixError(interp), (char *) NULL); 2385 return TCL_ERROR; 2386 } 2387 } else { 2388 /* Read link */ 2389 contents = Tcl_FSLink(objv[1], NULL, 0); 2390 if (contents == NULL) { 2391 Tcl_AppendResult(interp, "could not read link \"", 2392 Tcl_GetString(objv[1]), "\": ", 2393 Tcl_PosixError(interp), (char *) NULL); 2394 return TCL_ERROR; 2395 } 2396 } 2397 Tcl_SetObjResult(interp, contents); 2398 if (objc == 2) { 2399 /* 2400 * If we are creating a link, this will actually just 2401 * be objv[3], and we don't own it 2402 */ 2403 Tcl_DecrRefCount(contents); 2404 } 2405 return TCL_OK; 2406} 2407 2408/* 2409 *---------------------------------------------------------------------- 2410 * 2411 * TestgetassocdataCmd -- 2412 * 2413 * This procedure implements the "testgetassocdata" command. It is 2414 * used to test Tcl_GetAssocData. 2415 * 2416 * Results: 2417 * A standard Tcl result. 2418 * 2419 * Side effects: 2420 * None. 2421 * 2422 *---------------------------------------------------------------------- 2423 */ 2424 2425static int 2426TestgetassocdataCmd(clientData, interp, argc, argv) 2427 ClientData clientData; /* Not used. */ 2428 Tcl_Interp *interp; /* Current interpreter. */ 2429 int argc; /* Number of arguments. */ 2430 CONST char **argv; /* Argument strings. */ 2431{ 2432 char *res; 2433 2434 if (argc != 2) { 2435 Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], 2436 " data_key\"", (char *) NULL); 2437 return TCL_ERROR; 2438 } 2439 res = (char *) Tcl_GetAssocData(interp, argv[1], NULL); 2440 if (res != NULL) { 2441 Tcl_AppendResult(interp, res, NULL); 2442 } 2443 return TCL_OK; 2444} 2445 2446/* 2447 *---------------------------------------------------------------------- 2448 * 2449 * TestgetplatformCmd -- 2450 * 2451 * This procedure implements the "testgetplatform" command. It is 2452 * used to retrievel the value of the tclPlatform global variable. 2453 * 2454 * Results: 2455 * A standard Tcl result. 2456 * 2457 * Side effects: 2458 * None. 2459 * 2460 *---------------------------------------------------------------------- 2461 */ 2462 2463static int 2464TestgetplatformCmd(clientData, interp, argc, argv) 2465 ClientData clientData; /* Not used. */ 2466 Tcl_Interp *interp; /* Current interpreter. */ 2467 int argc; /* Number of arguments. */ 2468 CONST char **argv; /* Argument strings. */ 2469{ 2470 static CONST char *platformStrings[] = { "unix", "mac", "windows" }; 2471 TclPlatformType *platform; 2472 2473#ifdef __WIN32__ 2474 platform = TclWinGetPlatform(); 2475#else 2476 platform = &tclPlatform; 2477#endif 2478 2479 if (argc != 1) { 2480 Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], 2481 (char *) NULL); 2482 return TCL_ERROR; 2483 } 2484 2485 Tcl_AppendResult(interp, platformStrings[*platform], NULL); 2486 return TCL_OK; 2487} 2488 2489/* 2490 *---------------------------------------------------------------------- 2491 * 2492 * TestinterpdeleteCmd -- 2493 * 2494 * This procedure tests the code in tclInterp.c that deals with 2495 * interpreter deletion. It deletes a user-specified interpreter 2496 * from the hierarchy, and subsequent code checks integrity. 2497 * 2498 * Results: 2499 * A standard Tcl result. 2500 * 2501 * Side effects: 2502 * Deletes one or more interpreters. 2503 * 2504 *---------------------------------------------------------------------- 2505 */ 2506 2507 /* ARGSUSED */ 2508static int 2509TestinterpdeleteCmd(dummy, interp, argc, argv) 2510 ClientData dummy; /* Not used. */ 2511 Tcl_Interp *interp; /* Current interpreter. */ 2512 int argc; /* Number of arguments. */ 2513 CONST char **argv; /* Argument strings. */ 2514{ 2515 Tcl_Interp *slaveToDelete; 2516 2517 if (argc != 2) { 2518 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], 2519 " path\"", (char *) NULL); 2520 return TCL_ERROR; 2521 } 2522 slaveToDelete = Tcl_GetSlave(interp, argv[1]); 2523 if (slaveToDelete == (Tcl_Interp *) NULL) { 2524 return TCL_ERROR; 2525 } 2526 Tcl_DeleteInterp(slaveToDelete); 2527 return TCL_OK; 2528} 2529 2530/* 2531 *---------------------------------------------------------------------- 2532 * 2533 * TestlinkCmd -- 2534 * 2535 * This procedure implements the "testlink" command. It is used 2536 * to test Tcl_LinkVar and related library procedures. 2537 * 2538 * Results: 2539 * A standard Tcl result. 2540 * 2541 * Side effects: 2542 * Creates and deletes various variable links, plus returns 2543 * values of the linked variables. 2544 * 2545 *---------------------------------------------------------------------- 2546 */ 2547 2548 /* ARGSUSED */ 2549static int 2550TestlinkCmd(dummy, interp, argc, argv) 2551 ClientData dummy; /* Not used. */ 2552 Tcl_Interp *interp; /* Current interpreter. */ 2553 int argc; /* Number of arguments. */ 2554 CONST char **argv; /* Argument strings. */ 2555{ 2556 static int intVar = 43; 2557 static int boolVar = 4; 2558 static double realVar = 1.23; 2559 static Tcl_WideInt wideVar = Tcl_LongAsWide(79); 2560 static char *stringVar = NULL; 2561 static int created = 0; 2562 char buffer[2*TCL_DOUBLE_SPACE]; 2563 int writable, flag; 2564 Tcl_Obj *tmp; 2565 2566 if (argc < 2) { 2567 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], 2568 " option ?arg arg arg arg arg?\"", (char *) NULL); 2569 return TCL_ERROR; 2570 } 2571 if (strcmp(argv[1], "create") == 0) { 2572 if (argc != 7) { 2573 Tcl_AppendResult(interp, "wrong # args: should be \"", 2574 argv[0], " ", argv[1], 2575 " intRO realRO boolRO stringRO wideRO\"", (char *) NULL); 2576 return TCL_ERROR; 2577 } 2578 if (created) { 2579 Tcl_UnlinkVar(interp, "int"); 2580 Tcl_UnlinkVar(interp, "real"); 2581 Tcl_UnlinkVar(interp, "bool"); 2582 Tcl_UnlinkVar(interp, "string"); 2583 Tcl_UnlinkVar(interp, "wide"); 2584 } 2585 created = 1; 2586 if (Tcl_GetBoolean(interp, argv[2], &writable) != TCL_OK) { 2587 return TCL_ERROR; 2588 } 2589 flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; 2590 if (Tcl_LinkVar(interp, "int", (char *) &intVar, 2591 TCL_LINK_INT | flag) != TCL_OK) { 2592 return TCL_ERROR; 2593 } 2594 if (Tcl_GetBoolean(interp, argv[3], &writable) != TCL_OK) { 2595 return TCL_ERROR; 2596 } 2597 flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; 2598 if (Tcl_LinkVar(interp, "real", (char *) &realVar, 2599 TCL_LINK_DOUBLE | flag) != TCL_OK) { 2600 return TCL_ERROR; 2601 } 2602 if (Tcl_GetBoolean(interp, argv[4], &writable) != TCL_OK) { 2603 return TCL_ERROR; 2604 } 2605 flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; 2606 if (Tcl_LinkVar(interp, "bool", (char *) &boolVar, 2607 TCL_LINK_BOOLEAN | flag) != TCL_OK) { 2608 return TCL_ERROR; 2609 } 2610 if (Tcl_GetBoolean(interp, argv[5], &writable) != TCL_OK) { 2611 return TCL_ERROR; 2612 } 2613 flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; 2614 if (Tcl_LinkVar(interp, "string", (char *) &stringVar, 2615 TCL_LINK_STRING | flag) != TCL_OK) { 2616 return TCL_ERROR; 2617 } 2618 if (Tcl_GetBoolean(interp, argv[6], &writable) != TCL_OK) { 2619 return TCL_ERROR; 2620 } 2621 flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; 2622 if (Tcl_LinkVar(interp, "wide", (char *) &wideVar, 2623 TCL_LINK_WIDE_INT | flag) != TCL_OK) { 2624 return TCL_ERROR; 2625 } 2626 } else if (strcmp(argv[1], "delete") == 0) { 2627 Tcl_UnlinkVar(interp, "int"); 2628 Tcl_UnlinkVar(interp, "real"); 2629 Tcl_UnlinkVar(interp, "bool"); 2630 Tcl_UnlinkVar(interp, "string"); 2631 Tcl_UnlinkVar(interp, "wide"); 2632 created = 0; 2633 } else if (strcmp(argv[1], "get") == 0) { 2634 TclFormatInt(buffer, intVar); 2635 Tcl_AppendElement(interp, buffer); 2636 Tcl_PrintDouble((Tcl_Interp *) NULL, realVar, buffer); 2637 Tcl_AppendElement(interp, buffer); 2638 TclFormatInt(buffer, boolVar); 2639 Tcl_AppendElement(interp, buffer); 2640 Tcl_AppendElement(interp, (stringVar == NULL) ? "-" : stringVar); 2641 /* 2642 * Wide ints only have an object-based interface. 2643 */ 2644 tmp = Tcl_NewWideIntObj(wideVar); 2645 Tcl_AppendElement(interp, Tcl_GetString(tmp)); 2646 Tcl_DecrRefCount(tmp); 2647 } else if (strcmp(argv[1], "set") == 0) { 2648 if (argc != 7) { 2649 Tcl_AppendResult(interp, "wrong # args: should be \"", 2650 argv[0], " ", argv[1], 2651 " intValue realValue boolValue stringValue wideValue\"", 2652 (char *) NULL); 2653 return TCL_ERROR; 2654 } 2655 if (argv[2][0] != 0) { 2656 if (Tcl_GetInt(interp, argv[2], &intVar) != TCL_OK) { 2657 return TCL_ERROR; 2658 } 2659 } 2660 if (argv[3][0] != 0) { 2661 if (Tcl_GetDouble(interp, argv[3], &realVar) != TCL_OK) { 2662 return TCL_ERROR; 2663 } 2664 } 2665 if (argv[4][0] != 0) { 2666 if (Tcl_GetInt(interp, argv[4], &boolVar) != TCL_OK) { 2667 return TCL_ERROR; 2668 } 2669 } 2670 if (argv[5][0] != 0) { 2671 if (stringVar != NULL) { 2672 ckfree(stringVar); 2673 } 2674 if (strcmp(argv[5], "-") == 0) { 2675 stringVar = NULL; 2676 } else { 2677 stringVar = (char *) ckalloc((unsigned) (strlen(argv[5]) + 1)); 2678 strcpy(stringVar, argv[5]); 2679 } 2680 } 2681 if (argv[6][0] != 0) { 2682 tmp = Tcl_NewStringObj(argv[6], -1); 2683 if (Tcl_GetWideIntFromObj(interp, tmp, &wideVar) != TCL_OK) { 2684 Tcl_DecrRefCount(tmp); 2685 return TCL_ERROR; 2686 } 2687 Tcl_DecrRefCount(tmp); 2688 } 2689 } else if (strcmp(argv[1], "update") == 0) { 2690 if (argc != 7) { 2691 Tcl_AppendResult(interp, "wrong # args: should be \"", 2692 argv[0], " ", argv[1], 2693 "intValue realValue boolValue stringValue wideValue\"", 2694 (char *) NULL); 2695 return TCL_ERROR; 2696 } 2697 if (argv[2][0] != 0) { 2698 if (Tcl_GetInt(interp, argv[2], &intVar) != TCL_OK) { 2699 return TCL_ERROR; 2700 } 2701 Tcl_UpdateLinkedVar(interp, "int"); 2702 } 2703 if (argv[3][0] != 0) { 2704 if (Tcl_GetDouble(interp, argv[3], &realVar) != TCL_OK) { 2705 return TCL_ERROR; 2706 } 2707 Tcl_UpdateLinkedVar(interp, "real"); 2708 } 2709 if (argv[4][0] != 0) { 2710 if (Tcl_GetInt(interp, argv[4], &boolVar) != TCL_OK) { 2711 return TCL_ERROR; 2712 } 2713 Tcl_UpdateLinkedVar(interp, "bool"); 2714 } 2715 if (argv[5][0] != 0) { 2716 if (stringVar != NULL) { 2717 ckfree(stringVar); 2718 } 2719 if (strcmp(argv[5], "-") == 0) { 2720 stringVar = NULL; 2721 } else { 2722 stringVar = (char *) ckalloc((unsigned) (strlen(argv[5]) + 1)); 2723 strcpy(stringVar, argv[5]); 2724 } 2725 Tcl_UpdateLinkedVar(interp, "string"); 2726 } 2727 if (argv[6][0] != 0) { 2728 tmp = Tcl_NewStringObj(argv[6], -1); 2729 if (Tcl_GetWideIntFromObj(interp, tmp, &wideVar) != TCL_OK) { 2730 Tcl_DecrRefCount(tmp); 2731 return TCL_ERROR; 2732 } 2733 Tcl_DecrRefCount(tmp); 2734 Tcl_UpdateLinkedVar(interp, "wide"); 2735 } 2736 } else { 2737 Tcl_AppendResult(interp, "bad option \"", argv[1], 2738 "\": should be create, delete, get, set, or update", 2739 (char *) NULL); 2740 return TCL_ERROR; 2741 } 2742 return TCL_OK; 2743} 2744 2745/* 2746 *---------------------------------------------------------------------- 2747 * 2748 * TestlocaleCmd -- 2749 * 2750 * This procedure implements the "testlocale" command. It is used 2751 * to test the effects of setting different locales in Tcl. 2752 * 2753 * Results: 2754 * A standard Tcl result. 2755 * 2756 * Side effects: 2757 * Modifies the current C locale. 2758 * 2759 *---------------------------------------------------------------------- 2760 */ 2761 2762static int 2763TestlocaleCmd(clientData, interp, objc, objv) 2764 ClientData clientData; /* Not used. */ 2765 Tcl_Interp *interp; /* Current interpreter. */ 2766 int objc; /* Number of arguments. */ 2767 Tcl_Obj *CONST objv[]; /* The argument objects. */ 2768{ 2769 int index; 2770 char *locale; 2771 2772 static CONST char *optionStrings[] = { 2773 "ctype", "numeric", "time", "collate", "monetary", 2774 "all", NULL 2775 }; 2776 static int lcTypes[] = { 2777 LC_CTYPE, LC_NUMERIC, LC_TIME, LC_COLLATE, LC_MONETARY, 2778 LC_ALL 2779 }; 2780 2781 /* 2782 * LC_CTYPE, etc. correspond to the indices for the strings. 2783 */ 2784 2785 if (objc < 2 || objc > 3) { 2786 Tcl_WrongNumArgs(interp, 1, objv, "category ?locale?"); 2787 return TCL_ERROR; 2788 } 2789 2790 if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0, 2791 &index) != TCL_OK) { 2792 return TCL_ERROR; 2793 } 2794 2795 if (objc == 3) { 2796 locale = Tcl_GetString(objv[2]); 2797 } else { 2798 locale = NULL; 2799 } 2800 locale = setlocale(lcTypes[index], locale); 2801 if (locale) { 2802 Tcl_SetStringObj(Tcl_GetObjResult(interp), locale, -1); 2803 } 2804 return TCL_OK; 2805} 2806 2807/* 2808 *---------------------------------------------------------------------- 2809 * 2810 * TestMathFunc -- 2811 * 2812 * This is a user-defined math procedure to test out math procedures 2813 * with no arguments. 2814 * 2815 * Results: 2816 * A normal Tcl completion code. 2817 * 2818 * Side effects: 2819 * None. 2820 * 2821 *---------------------------------------------------------------------- 2822 */ 2823 2824 /* ARGSUSED */ 2825static int 2826TestMathFunc(clientData, interp, args, resultPtr) 2827 ClientData clientData; /* Integer value to return. */ 2828 Tcl_Interp *interp; /* Not used. */ 2829 Tcl_Value *args; /* Not used. */ 2830 Tcl_Value *resultPtr; /* Where to store result. */ 2831{ 2832 resultPtr->type = TCL_INT; 2833 resultPtr->intValue = (int) clientData; 2834 return TCL_OK; 2835} 2836 2837/* 2838 *---------------------------------------------------------------------- 2839 * 2840 * TestMathFunc2 -- 2841 * 2842 * This is a user-defined math procedure to test out math procedures 2843 * that do have arguments, in this case 2. 2844 * 2845 * Results: 2846 * A normal Tcl completion code. 2847 * 2848 * Side effects: 2849 * None. 2850 * 2851 *---------------------------------------------------------------------- 2852 */ 2853 2854 /* ARGSUSED */ 2855static int 2856TestMathFunc2(clientData, interp, args, resultPtr) 2857 ClientData clientData; /* Integer value to return. */ 2858 Tcl_Interp *interp; /* Used to report errors. */ 2859 Tcl_Value *args; /* Points to an array of two 2860 * Tcl_Value structs for the 2861 * two arguments. */ 2862 Tcl_Value *resultPtr; /* Where to store the result. */ 2863{ 2864 int result = TCL_OK; 2865 2866 /* 2867 * Return the maximum of the two arguments with the correct type. 2868 */ 2869 2870 if (args[0].type == TCL_INT) { 2871 int i0 = args[0].intValue; 2872 2873 if (args[1].type == TCL_INT) { 2874 int i1 = args[1].intValue; 2875 2876 resultPtr->type = TCL_INT; 2877 resultPtr->intValue = ((i0 > i1)? i0 : i1); 2878 } else if (args[1].type == TCL_DOUBLE) { 2879 double d0 = i0; 2880 double d1 = args[1].doubleValue; 2881 2882 resultPtr->type = TCL_DOUBLE; 2883 resultPtr->doubleValue = ((d0 > d1)? d0 : d1); 2884 } else if (args[1].type == TCL_WIDE_INT) { 2885 Tcl_WideInt w0 = Tcl_LongAsWide(i0); 2886 Tcl_WideInt w1 = args[1].wideValue; 2887 2888 resultPtr->type = TCL_WIDE_INT; 2889 resultPtr->wideValue = ((w0 > w1)? w0 : w1); 2890 } else { 2891 Tcl_SetResult(interp, "T3: wrong type for arg 2", TCL_STATIC); 2892 result = TCL_ERROR; 2893 } 2894 } else if (args[0].type == TCL_DOUBLE) { 2895 double d0 = args[0].doubleValue; 2896 2897 if (args[1].type == TCL_INT) { 2898 double d1 = args[1].intValue; 2899 2900 resultPtr->type = TCL_DOUBLE; 2901 resultPtr->doubleValue = ((d0 > d1)? d0 : d1); 2902 } else if (args[1].type == TCL_DOUBLE) { 2903 double d1 = args[1].doubleValue; 2904 2905 resultPtr->type = TCL_DOUBLE; 2906 resultPtr->doubleValue = ((d0 > d1)? d0 : d1); 2907 } else if (args[1].type == TCL_WIDE_INT) { 2908 double d1 = Tcl_WideAsDouble(args[1].wideValue); 2909 2910 resultPtr->type = TCL_DOUBLE; 2911 resultPtr->doubleValue = ((d0 > d1)? d0 : d1); 2912 } else { 2913 Tcl_SetResult(interp, "T3: wrong type for arg 2", TCL_STATIC); 2914 result = TCL_ERROR; 2915 } 2916 } else if (args[0].type == TCL_WIDE_INT) { 2917 Tcl_WideInt w0 = args[0].wideValue; 2918 2919 if (args[1].type == TCL_INT) { 2920 Tcl_WideInt w1 = Tcl_LongAsWide(args[1].intValue); 2921 2922 resultPtr->type = TCL_WIDE_INT; 2923 resultPtr->wideValue = ((w0 > w1)? w0 : w1); 2924 } else if (args[1].type == TCL_DOUBLE) { 2925 double d0 = Tcl_WideAsDouble(w0); 2926 double d1 = args[1].doubleValue; 2927 2928 resultPtr->type = TCL_DOUBLE; 2929 resultPtr->doubleValue = ((d0 > d1)? d0 : d1); 2930 } else if (args[1].type == TCL_WIDE_INT) { 2931 Tcl_WideInt w1 = args[1].wideValue; 2932 2933 resultPtr->type = TCL_WIDE_INT; 2934 resultPtr->wideValue = ((w0 > w1)? w0 : w1); 2935 } else { 2936 Tcl_SetResult(interp, "T3: wrong type for arg 2", TCL_STATIC); 2937 result = TCL_ERROR; 2938 } 2939 } else { 2940 Tcl_SetResult(interp, "T3: wrong type for arg 1", TCL_STATIC); 2941 result = TCL_ERROR; 2942 } 2943 return result; 2944} 2945 2946/* 2947 *---------------------------------------------------------------------- 2948 * 2949 * CleanupTestSetassocdataTests -- 2950 * 2951 * This function is called when an interpreter is deleted to clean 2952 * up any data left over from running the testsetassocdata command. 2953 * 2954 * Results: 2955 * None. 2956 * 2957 * Side effects: 2958 * Releases storage. 2959 * 2960 *---------------------------------------------------------------------- 2961 */ 2962 /* ARGSUSED */ 2963static void 2964CleanupTestSetassocdataTests(clientData, interp) 2965 ClientData clientData; /* Data to be released. */ 2966 Tcl_Interp *interp; /* Interpreter being deleted. */ 2967{ 2968 ckfree((char *) clientData); 2969} 2970 2971/* 2972 *---------------------------------------------------------------------- 2973 * 2974 * TestparserObjCmd -- 2975 * 2976 * This procedure implements the "testparser" command. It is 2977 * used for testing the new Tcl script parser in Tcl 8.1. 2978 * 2979 * Results: 2980 * A standard Tcl result. 2981 * 2982 * Side effects: 2983 * None. 2984 * 2985 *---------------------------------------------------------------------- 2986 */ 2987 2988static int 2989TestparserObjCmd(clientData, interp, objc, objv) 2990 ClientData clientData; /* Not used. */ 2991 Tcl_Interp *interp; /* Current interpreter. */ 2992 int objc; /* Number of arguments. */ 2993 Tcl_Obj *CONST objv[]; /* The argument objects. */ 2994{ 2995 char *script; 2996 int length, dummy; 2997 Tcl_Parse parse; 2998 2999 if (objc != 3) { 3000 Tcl_WrongNumArgs(interp, 1, objv, "script length"); 3001 return TCL_ERROR; 3002 } 3003 script = Tcl_GetStringFromObj(objv[1], &dummy); 3004 if (Tcl_GetIntFromObj(interp, objv[2], &length)) { 3005 return TCL_ERROR; 3006 } 3007 if (length == 0) { 3008 length = dummy; 3009 } 3010 if (Tcl_ParseCommand(interp, script, length, 0, &parse) != TCL_OK) { 3011 Tcl_AddErrorInfo(interp, "\n (remainder of script: \""); 3012 Tcl_AddErrorInfo(interp, parse.term); 3013 Tcl_AddErrorInfo(interp, "\")"); 3014 return TCL_ERROR; 3015 } 3016 3017 /* 3018 * The parse completed successfully. Just print out the contents 3019 * of the parse structure into the interpreter's result. 3020 */ 3021 3022 PrintParse(interp, &parse); 3023 Tcl_FreeParse(&parse); 3024 return TCL_OK; 3025} 3026 3027/* 3028 *---------------------------------------------------------------------- 3029 * 3030 * TestexprparserObjCmd -- 3031 * 3032 * This procedure implements the "testexprparser" command. It is 3033 * used for testing the new Tcl expression parser in Tcl 8.1. 3034 * 3035 * Results: 3036 * A standard Tcl result. 3037 * 3038 * Side effects: 3039 * None. 3040 * 3041 *---------------------------------------------------------------------- 3042 */ 3043 3044static int 3045TestexprparserObjCmd(clientData, interp, objc, objv) 3046 ClientData clientData; /* Not used. */ 3047 Tcl_Interp *interp; /* Current interpreter. */ 3048 int objc; /* Number of arguments. */ 3049 Tcl_Obj *CONST objv[]; /* The argument objects. */ 3050{ 3051 char *script; 3052 int length, dummy; 3053 Tcl_Parse parse; 3054 3055 if (objc != 3) { 3056 Tcl_WrongNumArgs(interp, 1, objv, "expr length"); 3057 return TCL_ERROR; 3058 } 3059 script = Tcl_GetStringFromObj(objv[1], &dummy); 3060 if (Tcl_GetIntFromObj(interp, objv[2], &length)) { 3061 return TCL_ERROR; 3062 } 3063 if (length == 0) { 3064 length = dummy; 3065 } 3066 if (Tcl_ParseExpr(interp, script, length, &parse) != TCL_OK) { 3067 Tcl_AddErrorInfo(interp, "\n (remainder of expr: \""); 3068 Tcl_AddErrorInfo(interp, parse.term); 3069 Tcl_AddErrorInfo(interp, "\")"); 3070 return TCL_ERROR; 3071 } 3072 3073 /* 3074 * The parse completed successfully. Just print out the contents 3075 * of the parse structure into the interpreter's result. 3076 */ 3077 3078 PrintParse(interp, &parse); 3079 Tcl_FreeParse(&parse); 3080 return TCL_OK; 3081} 3082 3083/* 3084 *---------------------------------------------------------------------- 3085 * 3086 * PrintParse -- 3087 * 3088 * This procedure prints out the contents of a Tcl_Parse structure 3089 * in the result of an interpreter. 3090 * 3091 * Results: 3092 * Interp's result is set to a prettily formatted version of the 3093 * contents of parsePtr. 3094 * 3095 * Side effects: 3096 * None. 3097 * 3098 *---------------------------------------------------------------------- 3099 */ 3100 3101static void 3102PrintParse(interp, parsePtr) 3103 Tcl_Interp *interp; /* Interpreter whose result is to be set to 3104 * the contents of a parse structure. */ 3105 Tcl_Parse *parsePtr; /* Parse structure to print out. */ 3106{ 3107 Tcl_Obj *objPtr; 3108 char *typeString; 3109 Tcl_Token *tokenPtr; 3110 int i; 3111 3112 objPtr = Tcl_GetObjResult(interp); 3113 if (parsePtr->commentSize > 0) { 3114 Tcl_ListObjAppendElement((Tcl_Interp *) NULL, objPtr, 3115 Tcl_NewStringObj(parsePtr->commentStart, 3116 parsePtr->commentSize)); 3117 } else { 3118 Tcl_ListObjAppendElement((Tcl_Interp *) NULL, objPtr, 3119 Tcl_NewStringObj("-", 1)); 3120 } 3121 Tcl_ListObjAppendElement((Tcl_Interp *) NULL, objPtr, 3122 Tcl_NewStringObj(parsePtr->commandStart, parsePtr->commandSize)); 3123 Tcl_ListObjAppendElement((Tcl_Interp *) NULL, objPtr, 3124 Tcl_NewIntObj(parsePtr->numWords)); 3125 for (i = 0; i < parsePtr->numTokens; i++) { 3126 tokenPtr = &parsePtr->tokenPtr[i]; 3127 switch (tokenPtr->type) { 3128 case TCL_TOKEN_WORD: 3129 typeString = "word"; 3130 break; 3131 case TCL_TOKEN_SIMPLE_WORD: 3132 typeString = "simple"; 3133 break; 3134 case TCL_TOKEN_TEXT: 3135 typeString = "text"; 3136 break; 3137 case TCL_TOKEN_BS: 3138 typeString = "backslash"; 3139 break; 3140 case TCL_TOKEN_COMMAND: 3141 typeString = "command"; 3142 break; 3143 case TCL_TOKEN_VARIABLE: 3144 typeString = "variable"; 3145 break; 3146 case TCL_TOKEN_SUB_EXPR: 3147 typeString = "subexpr"; 3148 break; 3149 case TCL_TOKEN_OPERATOR: 3150 typeString = "operator"; 3151 break; 3152 default: 3153 typeString = "??"; 3154 break; 3155 } 3156 Tcl_ListObjAppendElement((Tcl_Interp *) NULL, objPtr, 3157 Tcl_NewStringObj(typeString, -1)); 3158 Tcl_ListObjAppendElement((Tcl_Interp *) NULL, objPtr, 3159 Tcl_NewStringObj(tokenPtr->start, tokenPtr->size)); 3160 Tcl_ListObjAppendElement((Tcl_Interp *) NULL, objPtr, 3161 Tcl_NewIntObj(tokenPtr->numComponents)); 3162 } 3163 Tcl_ListObjAppendElement((Tcl_Interp *) NULL, objPtr, 3164 Tcl_NewStringObj(parsePtr->commandStart + parsePtr->commandSize, 3165 -1)); 3166} 3167 3168/* 3169 *---------------------------------------------------------------------- 3170 * 3171 * TestparsevarObjCmd -- 3172 * 3173 * This procedure implements the "testparsevar" command. It is 3174 * used for testing Tcl_ParseVar. 3175 * 3176 * Results: 3177 * A standard Tcl result. 3178 * 3179 * Side effects: 3180 * None. 3181 * 3182 *---------------------------------------------------------------------- 3183 */ 3184 3185static int 3186TestparsevarObjCmd(clientData, interp, objc, objv) 3187 ClientData clientData; /* Not used. */ 3188 Tcl_Interp *interp; /* Current interpreter. */ 3189 int objc; /* Number of arguments. */ 3190 Tcl_Obj *CONST objv[]; /* The argument objects. */ 3191{ 3192 CONST char *value; 3193 CONST char *name, *termPtr; 3194 3195 if (objc != 2) { 3196 Tcl_WrongNumArgs(interp, 1, objv, "varName"); 3197 return TCL_ERROR; 3198 } 3199 name = Tcl_GetString(objv[1]); 3200 value = Tcl_ParseVar(interp, name, &termPtr); 3201 if (value == NULL) { 3202 return TCL_ERROR; 3203 } 3204 3205 Tcl_AppendElement(interp, value); 3206 Tcl_AppendElement(interp, termPtr); 3207 return TCL_OK; 3208} 3209 3210/* 3211 *---------------------------------------------------------------------- 3212 * 3213 * TestparsevarnameObjCmd -- 3214 * 3215 * This procedure implements the "testparsevarname" command. It is 3216 * used for testing the new Tcl script parser in Tcl 8.1. 3217 * 3218 * Results: 3219 * A standard Tcl result. 3220 * 3221 * Side effects: 3222 * None. 3223 * 3224 *---------------------------------------------------------------------- 3225 */ 3226 3227static int 3228TestparsevarnameObjCmd(clientData, interp, objc, objv) 3229 ClientData clientData; /* Not used. */ 3230 Tcl_Interp *interp; /* Current interpreter. */ 3231 int objc; /* Number of arguments. */ 3232 Tcl_Obj *CONST objv[]; /* The argument objects. */ 3233{ 3234 char *script; 3235 int append, length, dummy; 3236 Tcl_Parse parse; 3237 3238 if (objc != 4) { 3239 Tcl_WrongNumArgs(interp, 1, objv, "script length append"); 3240 return TCL_ERROR; 3241 } 3242 script = Tcl_GetStringFromObj(objv[1], &dummy); 3243 if (Tcl_GetIntFromObj(interp, objv[2], &length)) { 3244 return TCL_ERROR; 3245 } 3246 if (length == 0) { 3247 length = dummy; 3248 } 3249 if (Tcl_GetIntFromObj(interp, objv[3], &append)) { 3250 return TCL_ERROR; 3251 } 3252 if (Tcl_ParseVarName(interp, script, length, &parse, append) != TCL_OK) { 3253 Tcl_AddErrorInfo(interp, "\n (remainder of script: \""); 3254 Tcl_AddErrorInfo(interp, parse.term); 3255 Tcl_AddErrorInfo(interp, "\")"); 3256 return TCL_ERROR; 3257 } 3258 3259 /* 3260 * The parse completed successfully. Just print out the contents 3261 * of the parse structure into the interpreter's result. 3262 */ 3263 3264 parse.commentSize = 0; 3265 parse.commandStart = script + parse.tokenPtr->size; 3266 parse.commandSize = 0; 3267 PrintParse(interp, &parse); 3268 Tcl_FreeParse(&parse); 3269 return TCL_OK; 3270} 3271 3272/* 3273 *---------------------------------------------------------------------- 3274 * 3275 * TestregexpObjCmd -- 3276 * 3277 * This procedure implements the "testregexp" command. It is 3278 * used to give a direct interface for regexp flags. It's identical 3279 * to Tcl_RegexpObjCmd except for the -xflags option, and the 3280 * consequences thereof (including the REG_EXPECT kludge). 3281 * 3282 * Results: 3283 * A standard Tcl result. 3284 * 3285 * Side effects: 3286 * See the user documentation. 3287 * 3288 *---------------------------------------------------------------------- 3289 */ 3290 3291 /* ARGSUSED */ 3292static int 3293TestregexpObjCmd(dummy, interp, objc, objv) 3294 ClientData dummy; /* Not used. */ 3295 Tcl_Interp *interp; /* Current interpreter. */ 3296 int objc; /* Number of arguments. */ 3297 Tcl_Obj *CONST objv[]; /* Argument objects. */ 3298{ 3299 int i, ii, indices, stringLength, match, about; 3300 int hasxflags, cflags, eflags; 3301 Tcl_RegExp regExpr; 3302 char *string; 3303 Tcl_Obj *objPtr; 3304 Tcl_RegExpInfo info; 3305 static CONST char *options[] = { 3306 "-indices", "-nocase", "-about", "-expanded", 3307 "-line", "-linestop", "-lineanchor", 3308 "-xflags", 3309 "--", (char *) NULL 3310 }; 3311 enum options { 3312 REGEXP_INDICES, REGEXP_NOCASE, REGEXP_ABOUT, REGEXP_EXPANDED, 3313 REGEXP_MULTI, REGEXP_NOCROSS, REGEXP_NEWL, 3314 REGEXP_XFLAGS, 3315 REGEXP_LAST 3316 }; 3317 3318 indices = 0; 3319 about = 0; 3320 cflags = REG_ADVANCED; 3321 eflags = 0; 3322 hasxflags = 0; 3323 3324 for (i = 1; i < objc; i++) { 3325 char *name; 3326 int index; 3327 3328 name = Tcl_GetString(objv[i]); 3329 if (name[0] != '-') { 3330 break; 3331 } 3332 if (Tcl_GetIndexFromObj(interp, objv[i], options, "switch", TCL_EXACT, 3333 &index) != TCL_OK) { 3334 return TCL_ERROR; 3335 } 3336 switch ((enum options) index) { 3337 case REGEXP_INDICES: { 3338 indices = 1; 3339 break; 3340 } 3341 case REGEXP_NOCASE: { 3342 cflags |= REG_ICASE; 3343 break; 3344 } 3345 case REGEXP_ABOUT: { 3346 about = 1; 3347 break; 3348 } 3349 case REGEXP_EXPANDED: { 3350 cflags |= REG_EXPANDED; 3351 break; 3352 } 3353 case REGEXP_MULTI: { 3354 cflags |= REG_NEWLINE; 3355 break; 3356 } 3357 case REGEXP_NOCROSS: { 3358 cflags |= REG_NLSTOP; 3359 break; 3360 } 3361 case REGEXP_NEWL: { 3362 cflags |= REG_NLANCH; 3363 break; 3364 } 3365 case REGEXP_XFLAGS: { 3366 hasxflags = 1; 3367 break; 3368 } 3369 case REGEXP_LAST: { 3370 i++; 3371 goto endOfForLoop; 3372 } 3373 } 3374 } 3375 3376 endOfForLoop: 3377 if (objc - i < hasxflags + 2 - about) { 3378 Tcl_WrongNumArgs(interp, 1, objv, 3379 "?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?"); 3380 return TCL_ERROR; 3381 } 3382 objc -= i; 3383 objv += i; 3384 3385 if (hasxflags) { 3386 string = Tcl_GetStringFromObj(objv[0], &stringLength); 3387 TestregexpXflags(string, stringLength, &cflags, &eflags); 3388 objc--; 3389 objv++; 3390 } 3391 3392 regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags); 3393 if (regExpr == NULL) { 3394 return TCL_ERROR; 3395 } 3396 objPtr = objv[1]; 3397 3398 if (about) { 3399 if (TclRegAbout(interp, regExpr) < 0) { 3400 return TCL_ERROR; 3401 } 3402 return TCL_OK; 3403 } 3404 3405 match = Tcl_RegExpExecObj(interp, regExpr, objPtr, 0 /* offset */, 3406 objc-2 /* nmatches */, eflags); 3407 3408 if (match < 0) { 3409 return TCL_ERROR; 3410 } 3411 if (match == 0) { 3412 /* 3413 * Set the interpreter's object result to an integer object w/ 3414 * value 0. 3415 */ 3416 3417 Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); 3418 if (objc > 2 && (cflags®_EXPECT) && indices) { 3419 char *varName; 3420 CONST char *value; 3421 int start, end; 3422 char resinfo[TCL_INTEGER_SPACE * 2]; 3423 3424 varName = Tcl_GetString(objv[2]); 3425 TclRegExpRangeUniChar(regExpr, -1, &start, &end); 3426 sprintf(resinfo, "%d %d", start, end-1); 3427 value = Tcl_SetVar(interp, varName, resinfo, 0); 3428 if (value == NULL) { 3429 Tcl_AppendResult(interp, "couldn't set variable \"", 3430 varName, "\"", (char *) NULL); 3431 return TCL_ERROR; 3432 } 3433 } else if (cflags & TCL_REG_CANMATCH) { 3434 char *varName; 3435 CONST char *value; 3436 char resinfo[TCL_INTEGER_SPACE * 2]; 3437 3438 Tcl_RegExpGetInfo(regExpr, &info); 3439 varName = Tcl_GetString(objv[2]); 3440 sprintf(resinfo, "%ld", info.extendStart); 3441 value = Tcl_SetVar(interp, varName, resinfo, 0); 3442 if (value == NULL) { 3443 Tcl_AppendResult(interp, "couldn't set variable \"", 3444 varName, "\"", (char *) NULL); 3445 return TCL_ERROR; 3446 } 3447 } 3448 return TCL_OK; 3449 } 3450 3451 /* 3452 * If additional variable names have been specified, return 3453 * index information in those variables. 3454 */ 3455 3456 objc -= 2; 3457 objv += 2; 3458 3459 Tcl_RegExpGetInfo(regExpr, &info); 3460 for (i = 0; i < objc; i++) { 3461 int start, end; 3462 Tcl_Obj *newPtr, *varPtr, *valuePtr; 3463 3464 varPtr = objv[i]; 3465 ii = ((cflags®_EXPECT) && i == objc-1) ? -1 : i; 3466 if (indices) { 3467 Tcl_Obj *objs[2]; 3468 3469 if (ii == -1) { 3470 TclRegExpRangeUniChar(regExpr, ii, &start, &end); 3471 } else if (ii > info.nsubs) { 3472 start = -1; 3473 end = -1; 3474 } else { 3475 start = info.matches[ii].start; 3476 end = info.matches[ii].end; 3477 } 3478 3479 /* 3480 * Adjust index so it refers to the last character in the 3481 * match instead of the first character after the match. 3482 */ 3483 3484 if (end >= 0) { 3485 end--; 3486 } 3487 3488 objs[0] = Tcl_NewLongObj(start); 3489 objs[1] = Tcl_NewLongObj(end); 3490 3491 newPtr = Tcl_NewListObj(2, objs); 3492 } else { 3493 if (ii == -1) { 3494 TclRegExpRangeUniChar(regExpr, ii, &start, &end); 3495 newPtr = Tcl_GetRange(objPtr, start, end); 3496 } else if (ii > info.nsubs) { 3497 newPtr = Tcl_NewObj(); 3498 } else { 3499 newPtr = Tcl_GetRange(objPtr, info.matches[ii].start, 3500 info.matches[ii].end - 1); 3501 } 3502 } 3503 Tcl_IncrRefCount(newPtr); 3504 valuePtr = Tcl_ObjSetVar2(interp, varPtr, NULL, newPtr, 0); 3505 Tcl_DecrRefCount(newPtr); 3506 if (valuePtr == NULL) { 3507 Tcl_AppendResult(interp, "couldn't set variable \"", 3508 Tcl_GetString(varPtr), "\"", (char *) NULL); 3509 return TCL_ERROR; 3510 } 3511 } 3512 3513 /* 3514 * Set the interpreter's object result to an integer object w/ value 1. 3515 */ 3516 3517 Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); 3518 return TCL_OK; 3519} 3520 3521/* 3522 *--------------------------------------------------------------------------- 3523 * 3524 * TestregexpXflags -- 3525 * 3526 * Parse a string of extended regexp flag letters, for testing. 3527 * 3528 * Results: 3529 * No return value (you're on your own for errors here). 3530 * 3531 * Side effects: 3532 * Modifies *cflagsPtr, a regcomp flags word, and *eflagsPtr, a 3533 * regexec flags word, as appropriate. 3534 * 3535 *---------------------------------------------------------------------- 3536 */ 3537 3538static void 3539TestregexpXflags(string, length, cflagsPtr, eflagsPtr) 3540 char *string; /* The string of flags. */ 3541 int length; /* The length of the string in bytes. */ 3542 int *cflagsPtr; /* compile flags word */ 3543 int *eflagsPtr; /* exec flags word */ 3544{ 3545 int i; 3546 int cflags; 3547 int eflags; 3548 3549 cflags = *cflagsPtr; 3550 eflags = *eflagsPtr; 3551 for (i = 0; i < length; i++) { 3552 switch (string[i]) { 3553 case 'a': { 3554 cflags |= REG_ADVF; 3555 break; 3556 } 3557 case 'b': { 3558 cflags &= ~REG_ADVANCED; 3559 break; 3560 } 3561 case 'c': { 3562 cflags |= TCL_REG_CANMATCH; 3563 break; 3564 } 3565 case 'e': { 3566 cflags &= ~REG_ADVANCED; 3567 cflags |= REG_EXTENDED; 3568 break; 3569 } 3570 case 'q': { 3571 cflags &= ~REG_ADVANCED; 3572 cflags |= REG_QUOTE; 3573 break; 3574 } 3575 case 'o': { /* o for opaque */ 3576 cflags |= REG_NOSUB; 3577 break; 3578 } 3579 case 's': { /* s for start */ 3580 cflags |= REG_BOSONLY; 3581 break; 3582 } 3583 case '+': { 3584 cflags |= REG_FAKE; 3585 break; 3586 } 3587 case ',': { 3588 cflags |= REG_PROGRESS; 3589 break; 3590 } 3591 case '.': { 3592 cflags |= REG_DUMP; 3593 break; 3594 } 3595 case ':': { 3596 eflags |= REG_MTRACE; 3597 break; 3598 } 3599 case ';': { 3600 eflags |= REG_FTRACE; 3601 break; 3602 } 3603 case '^': { 3604 eflags |= REG_NOTBOL; 3605 break; 3606 } 3607 case '$': { 3608 eflags |= REG_NOTEOL; 3609 break; 3610 } 3611 case 't': { 3612 cflags |= REG_EXPECT; 3613 break; 3614 } 3615 case '%': { 3616 eflags |= REG_SMALL; 3617 break; 3618 } 3619 } 3620 } 3621 3622 *cflagsPtr = cflags; 3623 *eflagsPtr = eflags; 3624} 3625 3626/* 3627 *---------------------------------------------------------------------- 3628 * 3629 * TestsetassocdataCmd -- 3630 * 3631 * This procedure implements the "testsetassocdata" command. It is used 3632 * to test Tcl_SetAssocData. 3633 * 3634 * Results: 3635 * A standard Tcl result. 3636 * 3637 * Side effects: 3638 * Modifies or creates an association between a key and associated 3639 * data for this interpreter. 3640 * 3641 *---------------------------------------------------------------------- 3642 */ 3643 3644static int 3645TestsetassocdataCmd(clientData, interp, argc, argv) 3646 ClientData clientData; /* Not used. */ 3647 Tcl_Interp *interp; /* Current interpreter. */ 3648 int argc; /* Number of arguments. */ 3649 CONST char **argv; /* Argument strings. */ 3650{ 3651 char *buf; 3652 char *oldData; 3653 Tcl_InterpDeleteProc *procPtr; 3654 3655 if (argc != 3) { 3656 Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], 3657 " data_key data_item\"", (char *) NULL); 3658 return TCL_ERROR; 3659 } 3660 3661 buf = ckalloc((unsigned) strlen(argv[2]) + 1); 3662 strcpy(buf, argv[2]); 3663 3664 /* 3665 * If we previously associated a malloced value with the variable, 3666 * free it before associating a new value. 3667 */ 3668 3669 oldData = (char *) Tcl_GetAssocData(interp, argv[1], &procPtr); 3670 if ((oldData != NULL) && (procPtr == CleanupTestSetassocdataTests)) { 3671 ckfree(oldData); 3672 } 3673 3674 Tcl_SetAssocData(interp, argv[1], CleanupTestSetassocdataTests, 3675 (ClientData) buf); 3676 return TCL_OK; 3677} 3678 3679/* 3680 *---------------------------------------------------------------------- 3681 * 3682 * TestsetplatformCmd -- 3683 * 3684 * This procedure implements the "testsetplatform" command. It is 3685 * used to change the tclPlatform global variable so all file 3686 * name conversions can be tested on a single platform. 3687 * 3688 * Results: 3689 * A standard Tcl result. 3690 * 3691 * Side effects: 3692 * Sets the tclPlatform global variable. 3693 * 3694 *---------------------------------------------------------------------- 3695 */ 3696 3697static int 3698TestsetplatformCmd(clientData, interp, argc, argv) 3699 ClientData clientData; /* Not used. */ 3700 Tcl_Interp *interp; /* Current interpreter. */ 3701 int argc; /* Number of arguments. */ 3702 CONST char **argv; /* Argument strings. */ 3703{ 3704 size_t length; 3705 TclPlatformType *platform; 3706 3707#ifdef __WIN32__ 3708 platform = TclWinGetPlatform(); 3709#else 3710 platform = &tclPlatform; 3711#endif 3712 3713 if (argc != 2) { 3714 Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], 3715 " platform\"", (char *) NULL); 3716 return TCL_ERROR; 3717 } 3718 3719 length = strlen(argv[1]); 3720 if (strncmp(argv[1], "unix", length) == 0) { 3721 *platform = TCL_PLATFORM_UNIX; 3722 } else if (strncmp(argv[1], "mac", length) == 0) { 3723 *platform = TCL_PLATFORM_MAC; 3724 } else if (strncmp(argv[1], "windows", length) == 0) { 3725 *platform = TCL_PLATFORM_WINDOWS; 3726 } else { 3727 Tcl_AppendResult(interp, "unsupported platform: should be one of ", 3728 "unix, mac, or windows", (char *) NULL); 3729 return TCL_ERROR; 3730 } 3731 return TCL_OK; 3732} 3733 3734/* 3735 *---------------------------------------------------------------------- 3736 * 3737 * TeststaticpkgCmd -- 3738 * 3739 * This procedure implements the "teststaticpkg" command. 3740 * It is used to test the procedure Tcl_StaticPackage. 3741 * 3742 * Results: 3743 * A standard Tcl result. 3744 * 3745 * Side effects: 3746 * When the packge given by argv[1] is loaded into an interpeter, 3747 * variable "x" in that interpreter is set to "loaded". 3748 * 3749 *---------------------------------------------------------------------- 3750 */ 3751 3752static int 3753TeststaticpkgCmd(dummy, interp, argc, argv) 3754 ClientData dummy; /* Not used. */ 3755 Tcl_Interp *interp; /* Current interpreter. */ 3756 int argc; /* Number of arguments. */ 3757 CONST char **argv; /* Argument strings. */ 3758{ 3759 int safe, loaded; 3760 3761 if (argc != 4) { 3762 Tcl_AppendResult(interp, "wrong # arguments: should be \"", 3763 argv[0], " pkgName safe loaded\"", (char *) NULL); 3764 return TCL_ERROR; 3765 } 3766 if (Tcl_GetInt(interp, argv[2], &safe) != TCL_OK) { 3767 return TCL_ERROR; 3768 } 3769 if (Tcl_GetInt(interp, argv[3], &loaded) != TCL_OK) { 3770 return TCL_ERROR; 3771 } 3772 Tcl_StaticPackage((loaded) ? interp : NULL, argv[1], StaticInitProc, 3773 (safe) ? StaticInitProc : NULL); 3774 return TCL_OK; 3775} 3776 3777static int 3778StaticInitProc(interp) 3779 Tcl_Interp *interp; /* Interpreter in which package 3780 * is supposedly being loaded. */ 3781{ 3782 Tcl_SetVar(interp, "x", "loaded", TCL_GLOBAL_ONLY); 3783 return TCL_OK; 3784} 3785 3786/* 3787 *---------------------------------------------------------------------- 3788 * 3789 * TesttranslatefilenameCmd -- 3790 * 3791 * This procedure implements the "testtranslatefilename" command. 3792 * It is used to test the Tcl_TranslateFileName command. 3793 * 3794 * Results: 3795 * A standard Tcl result. 3796 * 3797 * Side effects: 3798 * None. 3799 * 3800 *---------------------------------------------------------------------- 3801 */ 3802 3803static int 3804TesttranslatefilenameCmd(dummy, interp, argc, argv) 3805 ClientData dummy; /* Not used. */ 3806 Tcl_Interp *interp; /* Current interpreter. */ 3807 int argc; /* Number of arguments. */ 3808 CONST char **argv; /* Argument strings. */ 3809{ 3810 Tcl_DString buffer; 3811 CONST char *result; 3812 3813 if (argc != 2) { 3814 Tcl_AppendResult(interp, "wrong # arguments: should be \"", 3815 argv[0], " path\"", (char *) NULL); 3816 return TCL_ERROR; 3817 } 3818 result = Tcl_TranslateFileName(interp, argv[1], &buffer); 3819 if (result == NULL) { 3820 return TCL_ERROR; 3821 } 3822 Tcl_AppendResult(interp, result, NULL); 3823 Tcl_DStringFree(&buffer); 3824 return TCL_OK; 3825} 3826 3827/* 3828 *---------------------------------------------------------------------- 3829 * 3830 * TestupvarCmd -- 3831 * 3832 * This procedure implements the "testupvar2" command. It is used 3833 * to test Tcl_UpVar and Tcl_UpVar2. 3834 * 3835 * Results: 3836 * A standard Tcl result. 3837 * 3838 * Side effects: 3839 * Creates or modifies an "upvar" reference. 3840 * 3841 *---------------------------------------------------------------------- 3842 */ 3843 3844 /* ARGSUSED */ 3845static int 3846TestupvarCmd(dummy, interp, argc, argv) 3847 ClientData dummy; /* Not used. */ 3848 Tcl_Interp *interp; /* Current interpreter. */ 3849 int argc; /* Number of arguments. */ 3850 CONST char **argv; /* Argument strings. */ 3851{ 3852 int flags = 0; 3853 3854 if ((argc != 5) && (argc != 6)) { 3855 Tcl_AppendResult(interp, "wrong # arguments: should be \"", 3856 argv[0], " level name ?name2? dest global\"", (char *) NULL); 3857 return TCL_ERROR; 3858 } 3859 3860 if (argc == 5) { 3861 if (strcmp(argv[4], "global") == 0) { 3862 flags = TCL_GLOBAL_ONLY; 3863 } else if (strcmp(argv[4], "namespace") == 0) { 3864 flags = TCL_NAMESPACE_ONLY; 3865 } 3866 return Tcl_UpVar(interp, argv[1], argv[2], argv[3], flags); 3867 } else { 3868 if (strcmp(argv[5], "global") == 0) { 3869 flags = TCL_GLOBAL_ONLY; 3870 } else if (strcmp(argv[5], "namespace") == 0) { 3871 flags = TCL_NAMESPACE_ONLY; 3872 } 3873 return Tcl_UpVar2(interp, argv[1], argv[2], 3874 (argv[3][0] == 0) ? (char *) NULL : argv[3], argv[4], 3875 flags); 3876 } 3877} 3878 3879/* 3880 *---------------------------------------------------------------------- 3881 * 3882 * TestseterrorcodeCmd -- 3883 * 3884 * This procedure implements the "testseterrorcodeCmd". 3885 * This tests up to five elements passed to the 3886 * Tcl_SetErrorCode command. 3887 * 3888 * Results: 3889 * A standard Tcl result. Always returns TCL_ERROR so that 3890 * the error code can be tested. 3891 * 3892 * Side effects: 3893 * None. 3894 * 3895 *---------------------------------------------------------------------- 3896 */ 3897 3898 /* ARGSUSED */ 3899static int 3900TestseterrorcodeCmd(dummy, interp, argc, argv) 3901 ClientData dummy; /* Not used. */ 3902 Tcl_Interp *interp; /* Current interpreter. */ 3903 int argc; /* Number of arguments. */ 3904 CONST char **argv; /* Argument strings. */ 3905{ 3906 if (argc > 6) { 3907 Tcl_SetResult(interp, "too many args", TCL_STATIC); 3908 return TCL_ERROR; 3909 } 3910 Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], argv[4], 3911 argv[5], NULL); 3912 return TCL_ERROR; 3913} 3914 3915/* 3916 *---------------------------------------------------------------------- 3917 * 3918 * TestsetobjerrorcodeCmd -- 3919 * 3920 * This procedure implements the "testsetobjerrorcodeCmd". 3921 * This tests the Tcl_SetObjErrorCode function. 3922 * 3923 * Results: 3924 * A standard Tcl result. Always returns TCL_ERROR so that 3925 * the error code can be tested. 3926 * 3927 * Side effects: 3928 * None. 3929 * 3930 *---------------------------------------------------------------------- 3931 */ 3932 3933 /* ARGSUSED */ 3934static int 3935TestsetobjerrorcodeCmd(dummy, interp, objc, objv) 3936 ClientData dummy; /* Not used. */ 3937 Tcl_Interp *interp; /* Current interpreter. */ 3938 int objc; /* Number of arguments. */ 3939 Tcl_Obj *CONST objv[]; /* The argument objects. */ 3940{ 3941 Tcl_Obj *listObjPtr; 3942 3943 if (objc > 1) { 3944 listObjPtr = Tcl_ConcatObj(objc - 1, objv + 1); 3945 } else { 3946 listObjPtr = Tcl_NewObj(); 3947 } 3948 Tcl_IncrRefCount(listObjPtr); 3949 Tcl_SetObjErrorCode(interp, listObjPtr); 3950 Tcl_DecrRefCount(listObjPtr); 3951 return TCL_ERROR; 3952} 3953 3954/* 3955 *---------------------------------------------------------------------- 3956 * 3957 * TestfeventCmd -- 3958 * 3959 * This procedure implements the "testfevent" command. It is 3960 * used for testing the "fileevent" command. 3961 * 3962 * Results: 3963 * A standard Tcl result. 3964 * 3965 * Side effects: 3966 * Creates and deletes interpreters. 3967 * 3968 *---------------------------------------------------------------------- 3969 */ 3970 3971 /* ARGSUSED */ 3972static int 3973TestfeventCmd(clientData, interp, argc, argv) 3974 ClientData clientData; /* Not used. */ 3975 Tcl_Interp *interp; /* Current interpreter. */ 3976 int argc; /* Number of arguments. */ 3977 CONST char **argv; /* Argument strings. */ 3978{ 3979 static Tcl_Interp *interp2 = NULL; 3980 int code; 3981 Tcl_Channel chan; 3982 3983 if (argc < 2) { 3984 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], 3985 " option ?arg arg ...?", (char *) NULL); 3986 return TCL_ERROR; 3987 } 3988 if (strcmp(argv[1], "cmd") == 0) { 3989 if (argc != 3) { 3990 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], 3991 " cmd script", (char *) NULL); 3992 return TCL_ERROR; 3993 } 3994 if (interp2 != (Tcl_Interp *) NULL) { 3995 code = Tcl_GlobalEval(interp2, argv[2]); 3996 Tcl_SetObjResult(interp, Tcl_GetObjResult(interp2)); 3997 return code; 3998 } else { 3999 Tcl_AppendResult(interp, 4000 "called \"testfevent code\" before \"testfevent create\"", 4001 (char *) NULL); 4002 return TCL_ERROR; 4003 } 4004 } else if (strcmp(argv[1], "create") == 0) { 4005 if (interp2 != NULL) { 4006 Tcl_DeleteInterp(interp2); 4007 } 4008 interp2 = Tcl_CreateInterp(); 4009 return Tcl_Init(interp2); 4010 } else if (strcmp(argv[1], "delete") == 0) { 4011 if (interp2 != NULL) { 4012 Tcl_DeleteInterp(interp2); 4013 } 4014 interp2 = NULL; 4015 } else if (strcmp(argv[1], "share") == 0) { 4016 if (interp2 != NULL) { 4017 chan = Tcl_GetChannel(interp, argv[2], NULL); 4018 if (chan == (Tcl_Channel) NULL) { 4019 return TCL_ERROR; 4020 } 4021 Tcl_RegisterChannel(interp2, chan); 4022 } 4023 } 4024 4025 return TCL_OK; 4026} 4027 4028/* 4029 *---------------------------------------------------------------------- 4030 * 4031 * TestpanicCmd -- 4032 * 4033 * Calls the panic routine. 4034 * 4035 * Results: 4036 * Always returns TCL_OK. 4037 * 4038 * Side effects: 4039 * May exit application. 4040 * 4041 *---------------------------------------------------------------------- 4042 */ 4043 4044static int 4045TestpanicCmd(dummy, interp, argc, argv) 4046 ClientData dummy; /* Not used. */ 4047 Tcl_Interp *interp; /* Current interpreter. */ 4048 int argc; /* Number of arguments. */ 4049 CONST char **argv; /* Argument strings. */ 4050{ 4051 CONST char *argString; 4052 4053 /* 4054 * Put the arguments into a var args structure 4055 * Append all of the arguments together separated by spaces 4056 */ 4057 4058 argString = Tcl_Merge(argc-1, argv+1); 4059 panic(argString); 4060 ckfree((char *)argString); 4061 4062 return TCL_OK; 4063} 4064 4065static int 4066TestfileCmd(dummy, interp, argc, argv) 4067 ClientData dummy; /* Not used. */ 4068 Tcl_Interp *interp; /* Current interpreter. */ 4069 int argc; /* Number of arguments. */ 4070 Tcl_Obj *CONST argv[]; /* The argument objects. */ 4071{ 4072 int force, i, j, result; 4073 Tcl_Obj *error = NULL; 4074 char *subcmd; 4075 4076 if (argc < 3) { 4077 return TCL_ERROR; 4078 } 4079 4080 force = 0; 4081 i = 2; 4082 if (strcmp(Tcl_GetString(argv[2]), "-force") == 0) { 4083 force = 1; 4084 i = 3; 4085 } 4086 4087 if (argc - i > 2) { 4088 return TCL_ERROR; 4089 } 4090 4091 for (j = i; j < argc; j++) { 4092 if (Tcl_FSGetNormalizedPath(interp, argv[j]) == NULL) { 4093 return TCL_ERROR; 4094 } 4095 } 4096 4097 subcmd = Tcl_GetString(argv[1]); 4098 4099 if (strcmp(subcmd, "mv") == 0) { 4100 result = TclpObjRenameFile(argv[i], argv[i + 1]); 4101 } else if (strcmp(subcmd, "cp") == 0) { 4102 result = TclpObjCopyFile(argv[i], argv[i + 1]); 4103 } else if (strcmp(subcmd, "rm") == 0) { 4104 result = TclpObjDeleteFile(argv[i]); 4105 } else if (strcmp(subcmd, "mkdir") == 0) { 4106 result = TclpObjCreateDirectory(argv[i]); 4107 } else if (strcmp(subcmd, "cpdir") == 0) { 4108 result = TclpObjCopyDirectory(argv[i], argv[i + 1], &error); 4109 } else if (strcmp(subcmd, "rmdir") == 0) { 4110 result = TclpObjRemoveDirectory(argv[i], force, &error); 4111 } else { 4112 result = TCL_ERROR; 4113 goto end; 4114 } 4115 4116 if (result != TCL_OK) { 4117 if (error != NULL) { 4118 if (Tcl_GetString(error)[0] != '\0') { 4119 Tcl_AppendResult(interp, Tcl_GetString(error), " ", NULL); 4120 } 4121 Tcl_DecrRefCount(error); 4122 } 4123 Tcl_AppendResult(interp, Tcl_ErrnoId(), (char *) NULL); 4124 } 4125 4126 end: 4127 4128 return result; 4129} 4130 4131/* 4132 *---------------------------------------------------------------------- 4133 * 4134 * TestgetvarfullnameCmd -- 4135 * 4136 * Implements the "testgetvarfullname" cmd that is used when testing 4137 * the Tcl_GetVariableFullName procedure. 4138 * 4139 * Results: 4140 * A standard Tcl result. 4141 * 4142 * Side effects: 4143 * None. 4144 * 4145 *---------------------------------------------------------------------- 4146 */ 4147 4148static int 4149TestgetvarfullnameCmd(dummy, interp, objc, objv) 4150 ClientData dummy; /* Not used. */ 4151 Tcl_Interp *interp; /* Current interpreter. */ 4152 int objc; /* Number of arguments. */ 4153 Tcl_Obj *CONST objv[]; /* The argument objects. */ 4154{ 4155 char *name, *arg; 4156 int flags = 0; 4157 Tcl_Namespace *namespacePtr; 4158 Tcl_CallFrame frame; 4159 Tcl_Var variable; 4160 int result; 4161 4162 if (objc != 3) { 4163 Tcl_WrongNumArgs(interp, 1, objv, "name scope"); 4164 return TCL_ERROR; 4165 } 4166 4167 name = Tcl_GetString(objv[1]); 4168 4169 arg = Tcl_GetString(objv[2]); 4170 if (strcmp(arg, "global") == 0) { 4171 flags = TCL_GLOBAL_ONLY; 4172 } else if (strcmp(arg, "namespace") == 0) { 4173 flags = TCL_NAMESPACE_ONLY; 4174 } 4175 4176 /* 4177 * This command, like any other created with Tcl_Create[Obj]Command, 4178 * runs in the global namespace. As a "namespace-aware" command that 4179 * needs to run in a particular namespace, it must activate that 4180 * namespace itself. 4181 */ 4182 4183 if (flags == TCL_NAMESPACE_ONLY) { 4184 namespacePtr = Tcl_FindNamespace(interp, "::test_ns_var", 4185 (Tcl_Namespace *) NULL, TCL_LEAVE_ERR_MSG); 4186 if (namespacePtr == NULL) { 4187 return TCL_ERROR; 4188 } 4189 result = Tcl_PushCallFrame(interp, &frame, namespacePtr, 4190 /*isProcCallFrame*/ 0); 4191 if (result != TCL_OK) { 4192 return result; 4193 } 4194 } 4195 4196 variable = Tcl_FindNamespaceVar(interp, name, (Tcl_Namespace *) NULL, 4197 (flags | TCL_LEAVE_ERR_MSG)); 4198 4199 if (flags == TCL_NAMESPACE_ONLY) { 4200 Tcl_PopCallFrame(interp); 4201 } 4202 if (variable == (Tcl_Var) NULL) { 4203 return TCL_ERROR; 4204 } 4205 Tcl_GetVariableFullName(interp, variable, Tcl_GetObjResult(interp)); 4206 return TCL_OK; 4207} 4208 4209/* 4210 *---------------------------------------------------------------------- 4211 * 4212 * GetTimesCmd -- 4213 * 4214 * This procedure implements the "gettimes" command. It is 4215 * used for computing the time needed for various basic operations 4216 * such as reading variables, allocating memory, sprintf, converting 4217 * variables, etc. 4218 * 4219 * Results: 4220 * A standard Tcl result. 4221 * 4222 * Side effects: 4223 * Allocates and frees memory, sets a variable "a" in the interpreter. 4224 * 4225 *---------------------------------------------------------------------- 4226 */ 4227 4228static int 4229GetTimesCmd(unused, interp, argc, argv) 4230 ClientData unused; /* Unused. */ 4231 Tcl_Interp *interp; /* The current interpreter. */ 4232 int argc; /* The number of arguments. */ 4233 CONST char **argv; /* The argument strings. */ 4234{ 4235 Interp *iPtr = (Interp *) interp; 4236 int i, n; 4237 double timePer; 4238 Tcl_Time start, stop; 4239 Tcl_Obj *objPtr; 4240 Tcl_Obj **objv; 4241 CONST char *s; 4242 char newString[TCL_INTEGER_SPACE]; 4243 4244 /* alloc & free 100000 times */ 4245 fprintf(stderr, "alloc & free 100000 6 word items\n"); 4246 Tcl_GetTime(&start); 4247 for (i = 0; i < 100000; i++) { 4248 objPtr = (Tcl_Obj *) ckalloc(sizeof(Tcl_Obj)); 4249 ckfree((char *) objPtr); 4250 } 4251 Tcl_GetTime(&stop); 4252 timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); 4253 fprintf(stderr, " %.3f usec per alloc+free\n", timePer/100000); 4254 4255 /* alloc 5000 times */ 4256 fprintf(stderr, "alloc 5000 6 word items\n"); 4257 objv = (Tcl_Obj **) ckalloc(5000 * sizeof(Tcl_Obj *)); 4258 Tcl_GetTime(&start); 4259 for (i = 0; i < 5000; i++) { 4260 objv[i] = (Tcl_Obj *) ckalloc(sizeof(Tcl_Obj)); 4261 } 4262 Tcl_GetTime(&stop); 4263 timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); 4264 fprintf(stderr, " %.3f usec per alloc\n", timePer/5000); 4265 4266 /* free 5000 times */ 4267 fprintf(stderr, "free 5000 6 word items\n"); 4268 Tcl_GetTime(&start); 4269 for (i = 0; i < 5000; i++) { 4270 ckfree((char *) objv[i]); 4271 } 4272 Tcl_GetTime(&stop); 4273 timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); 4274 fprintf(stderr, " %.3f usec per free\n", timePer/5000); 4275 4276 /* Tcl_NewObj 5000 times */ 4277 fprintf(stderr, "Tcl_NewObj 5000 times\n"); 4278 Tcl_GetTime(&start); 4279 for (i = 0; i < 5000; i++) { 4280 objv[i] = Tcl_NewObj(); 4281 } 4282 Tcl_GetTime(&stop); 4283 timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); 4284 fprintf(stderr, " %.3f usec per Tcl_NewObj\n", timePer/5000); 4285 4286 /* Tcl_DecrRefCount 5000 times */ 4287 fprintf(stderr, "Tcl_DecrRefCount 5000 times\n"); 4288 Tcl_GetTime(&start); 4289 for (i = 0; i < 5000; i++) { 4290 objPtr = objv[i]; 4291 Tcl_DecrRefCount(objPtr); 4292 } 4293 Tcl_GetTime(&stop); 4294 timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); 4295 fprintf(stderr, " %.3f usec per Tcl_DecrRefCount\n", timePer/5000); 4296 ckfree((char *) objv); 4297 4298 /* TclGetString 100000 times */ 4299 fprintf(stderr, "TclGetStringFromObj of \"12345\" 100000 times\n"); 4300 objPtr = Tcl_NewStringObj("12345", -1); 4301 Tcl_GetTime(&start); 4302 for (i = 0; i < 100000; i++) { 4303 (void) TclGetString(objPtr); 4304 } 4305 Tcl_GetTime(&stop); 4306 timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); 4307 fprintf(stderr, " %.3f usec per TclGetStringFromObj of \"12345\"\n", 4308 timePer/100000); 4309 4310 /* Tcl_GetIntFromObj 100000 times */ 4311 fprintf(stderr, "Tcl_GetIntFromObj of \"12345\" 100000 times\n"); 4312 Tcl_GetTime(&start); 4313 for (i = 0; i < 100000; i++) { 4314 if (Tcl_GetIntFromObj(interp, objPtr, &n) != TCL_OK) { 4315 return TCL_ERROR; 4316 } 4317 } 4318 Tcl_GetTime(&stop); 4319 timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); 4320 fprintf(stderr, " %.3f usec per Tcl_GetIntFromObj of \"12345\"\n", 4321 timePer/100000); 4322 Tcl_DecrRefCount(objPtr); 4323 4324 /* Tcl_GetInt 100000 times */ 4325 fprintf(stderr, "Tcl_GetInt of \"12345\" 100000 times\n"); 4326 Tcl_GetTime(&start); 4327 for (i = 0; i < 100000; i++) { 4328 if (Tcl_GetInt(interp, "12345", &n) != TCL_OK) { 4329 return TCL_ERROR; 4330 } 4331 } 4332 Tcl_GetTime(&stop); 4333 timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); 4334 fprintf(stderr, " %.3f usec per Tcl_GetInt of \"12345\"\n", 4335 timePer/100000); 4336 4337 /* sprintf 100000 times */ 4338 fprintf(stderr, "sprintf of 12345 100000 times\n"); 4339 Tcl_GetTime(&start); 4340 for (i = 0; i < 100000; i++) { 4341 sprintf(newString, "%d", 12345); 4342 } 4343 Tcl_GetTime(&stop); 4344 timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); 4345 fprintf(stderr, " %.3f usec per sprintf of 12345\n", 4346 timePer/100000); 4347 4348 /* hashtable lookup 100000 times */ 4349 fprintf(stderr, "hashtable lookup of \"gettimes\" 100000 times\n"); 4350 Tcl_GetTime(&start); 4351 for (i = 0; i < 100000; i++) { 4352 (void) Tcl_FindHashEntry(&iPtr->globalNsPtr->cmdTable, "gettimes"); 4353 } 4354 Tcl_GetTime(&stop); 4355 timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); 4356 fprintf(stderr, " %.3f usec per hashtable lookup of \"gettimes\"\n", 4357 timePer/100000); 4358 4359 /* Tcl_SetVar 100000 times */ 4360 fprintf(stderr, "Tcl_SetVar of \"12345\" 100000 times\n"); 4361 Tcl_GetTime(&start); 4362 for (i = 0; i < 100000; i++) { 4363 s = Tcl_SetVar(interp, "a", "12345", TCL_LEAVE_ERR_MSG); 4364 if (s == NULL) { 4365 return TCL_ERROR; 4366 } 4367 } 4368 Tcl_GetTime(&stop); 4369 timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); 4370 fprintf(stderr, " %.3f usec per Tcl_SetVar of a to \"12345\"\n", 4371 timePer/100000); 4372 4373 /* Tcl_GetVar 100000 times */ 4374 fprintf(stderr, "Tcl_GetVar of a==\"12345\" 100000 times\n"); 4375 Tcl_GetTime(&start); 4376 for (i = 0; i < 100000; i++) { 4377 s = Tcl_GetVar(interp, "a", TCL_LEAVE_ERR_MSG); 4378 if (s == NULL) { 4379 return TCL_ERROR; 4380 } 4381 } 4382 Tcl_GetTime(&stop); 4383 timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); 4384 fprintf(stderr, " %.3f usec per Tcl_GetVar of a==\"12345\"\n", 4385 timePer/100000); 4386 4387 Tcl_ResetResult(interp); 4388 return TCL_OK; 4389} 4390 4391/* 4392 *---------------------------------------------------------------------- 4393 * 4394 * NoopCmd -- 4395 * 4396 * This procedure is just used to time the overhead involved in 4397 * parsing and invoking a command. 4398 * 4399 * Results: 4400 * None. 4401 * 4402 * Side effects: 4403 * None. 4404 * 4405 *---------------------------------------------------------------------- 4406 */ 4407 4408static int 4409NoopCmd(unused, interp, argc, argv) 4410 ClientData unused; /* Unused. */ 4411 Tcl_Interp *interp; /* The current interpreter. */ 4412 int argc; /* The number of arguments. */ 4413 CONST char **argv; /* The argument strings. */ 4414{ 4415 return TCL_OK; 4416} 4417 4418/* 4419 *---------------------------------------------------------------------- 4420 * 4421 * NoopObjCmd -- 4422 * 4423 * This object-based procedure is just used to time the overhead 4424 * involved in parsing and invoking a command. 4425 * 4426 * Results: 4427 * Returns the TCL_OK result code. 4428 * 4429 * Side effects: 4430 * None. 4431 * 4432 *---------------------------------------------------------------------- 4433 */ 4434 4435static int 4436NoopObjCmd(unused, interp, objc, objv) 4437 ClientData unused; /* Not used. */ 4438 Tcl_Interp *interp; /* Current interpreter. */ 4439 int objc; /* Number of arguments. */ 4440 Tcl_Obj *CONST objv[]; /* The argument objects. */ 4441{ 4442 return TCL_OK; 4443} 4444 4445/* 4446 *---------------------------------------------------------------------- 4447 * 4448 * TestsetCmd -- 4449 * 4450 * Implements the "testset{err,noerr}" cmds that are used when testing 4451 * Tcl_Set/GetVar C Api with/without TCL_LEAVE_ERR_MSG flag 4452 * 4453 * Results: 4454 * A standard Tcl result. 4455 * 4456 * Side effects: 4457 * Variables may be set. 4458 * 4459 *---------------------------------------------------------------------- 4460 */ 4461 4462 /* ARGSUSED */ 4463static int 4464TestsetCmd(data, interp, argc, argv) 4465 ClientData data; /* Additional flags for Get/SetVar2. */ 4466 register Tcl_Interp *interp; /* Current interpreter. */ 4467 int argc; /* Number of arguments. */ 4468 CONST char **argv; /* Argument strings. */ 4469{ 4470 int flags = (int) data; 4471 CONST char *value; 4472 4473 if (argc == 2) { 4474 Tcl_SetResult(interp, "before get", TCL_STATIC); 4475 value = Tcl_GetVar2(interp, argv[1], (char *) NULL, flags); 4476 if (value == NULL) { 4477 return TCL_ERROR; 4478 } 4479 Tcl_AppendElement(interp, value); 4480 return TCL_OK; 4481 } else if (argc == 3) { 4482 Tcl_SetResult(interp, "before set", TCL_STATIC); 4483 value = Tcl_SetVar2(interp, argv[1], (char *) NULL, argv[2], flags); 4484 if (value == NULL) { 4485 return TCL_ERROR; 4486 } 4487 Tcl_AppendElement(interp, value); 4488 return TCL_OK; 4489 } else { 4490 Tcl_AppendResult(interp, "wrong # args: should be \"", 4491 argv[0], " varName ?newValue?\"", (char *) NULL); 4492 return TCL_ERROR; 4493 } 4494} 4495 4496/* 4497 *---------------------------------------------------------------------- 4498 * 4499 * TestsaveresultCmd -- 4500 * 4501 * Implements the "testsaveresult" cmd that is used when testing 4502 * the Tcl_SaveResult, Tcl_RestoreResult, and 4503 * Tcl_DiscardResult interfaces. 4504 * 4505 * Results: 4506 * A standard Tcl result. 4507 * 4508 * Side effects: 4509 * None. 4510 * 4511 *---------------------------------------------------------------------- 4512 */ 4513 4514 /* ARGSUSED */ 4515static int 4516TestsaveresultCmd(dummy, interp, objc, objv) 4517 ClientData dummy; /* Not used. */ 4518 register Tcl_Interp *interp; /* Current interpreter. */ 4519 int objc; /* Number of arguments. */ 4520 Tcl_Obj *CONST objv[]; /* The argument objects. */ 4521{ 4522 int discard, result, index; 4523 Tcl_SavedResult state; 4524 Tcl_Obj *objPtr; 4525 static CONST char *optionStrings[] = { 4526 "append", "dynamic", "free", "object", "small", NULL 4527 }; 4528 enum options { 4529 RESULT_APPEND, RESULT_DYNAMIC, RESULT_FREE, RESULT_OBJECT, RESULT_SMALL 4530 }; 4531 4532 /* 4533 * Parse arguments 4534 */ 4535 4536 if (objc != 4) { 4537 Tcl_WrongNumArgs(interp, 1, objv, "type script discard"); 4538 return TCL_ERROR; 4539 } 4540 if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0, 4541 &index) != TCL_OK) { 4542 return TCL_ERROR; 4543 } 4544 if (Tcl_GetBooleanFromObj(interp, objv[3], &discard) != TCL_OK) { 4545 return TCL_ERROR; 4546 } 4547 4548 objPtr = NULL; /* Lint. */ 4549 switch ((enum options) index) { 4550 case RESULT_SMALL: 4551 Tcl_SetResult(interp, "small result", TCL_VOLATILE); 4552 break; 4553 case RESULT_APPEND: 4554 Tcl_AppendResult(interp, "append result", NULL); 4555 break; 4556 case RESULT_FREE: { 4557 char *buf = ckalloc(200); 4558 strcpy(buf, "free result"); 4559 Tcl_SetResult(interp, buf, TCL_DYNAMIC); 4560 break; 4561 } 4562 case RESULT_DYNAMIC: 4563 Tcl_SetResult(interp, "dynamic result", TestsaveresultFree); 4564 break; 4565 case RESULT_OBJECT: 4566 objPtr = Tcl_NewStringObj("object result", -1); 4567 Tcl_SetObjResult(interp, objPtr); 4568 break; 4569 } 4570 4571 freeCount = 0; 4572 Tcl_SaveResult(interp, &state); 4573 4574 if (((enum options) index) == RESULT_OBJECT) { 4575 result = Tcl_EvalObjEx(interp, objv[2], 0); 4576 } else { 4577 result = Tcl_Eval(interp, Tcl_GetString(objv[2])); 4578 } 4579 4580 if (discard) { 4581 Tcl_DiscardResult(&state); 4582 } else { 4583 Tcl_RestoreResult(interp, &state); 4584 result = TCL_OK; 4585 } 4586 4587 switch ((enum options) index) { 4588 case RESULT_DYNAMIC: { 4589 int present = interp->freeProc == TestsaveresultFree; 4590 int called = freeCount; 4591 Tcl_AppendElement(interp, called ? "called" : "notCalled"); 4592 Tcl_AppendElement(interp, present ? "present" : "missing"); 4593 break; 4594 } 4595 case RESULT_OBJECT: 4596 Tcl_AppendElement(interp, Tcl_GetObjResult(interp) == objPtr 4597 ? "same" : "different"); 4598 break; 4599 default: 4600 break; 4601 } 4602 return result; 4603} 4604 4605/* 4606 *---------------------------------------------------------------------- 4607 * 4608 * TestsaveresultFree -- 4609 * 4610 * Special purpose freeProc used by TestsaveresultCmd. 4611 * 4612 * Results: 4613 * None. 4614 * 4615 * Side effects: 4616 * Increments the freeCount. 4617 * 4618 *---------------------------------------------------------------------- 4619 */ 4620 4621static void 4622TestsaveresultFree(blockPtr) 4623 char *blockPtr; 4624{ 4625 freeCount++; 4626} 4627 4628/* 4629 *---------------------------------------------------------------------- 4630 * 4631 * TeststatprocCmd -- 4632 * 4633 * Implements the "testTclStatProc" cmd that is used to test the 4634 * 'TclStatInsertProc' & 'TclStatDeleteProc' C Apis. 4635 * 4636 * Results: 4637 * A standard Tcl result. 4638 * 4639 * Side effects: 4640 * None. 4641 * 4642 *---------------------------------------------------------------------- 4643 */ 4644 4645static int 4646TeststatprocCmd (dummy, interp, argc, argv) 4647 ClientData dummy; /* Not used. */ 4648 register Tcl_Interp *interp; /* Current interpreter. */ 4649 int argc; /* Number of arguments. */ 4650 CONST char **argv; /* Argument strings. */ 4651{ 4652 TclStatProc_ *proc; 4653 int retVal; 4654 4655 if (argc != 3) { 4656 Tcl_AppendResult(interp, "wrong # args: should be \"", 4657 argv[0], " option arg\"", (char *) NULL); 4658 return TCL_ERROR; 4659 } 4660 4661 if (strcmp(argv[2], "TclpStat") == 0) { 4662 proc = PretendTclpStat; 4663 } else if (strcmp(argv[2], "TestStatProc1") == 0) { 4664 proc = TestStatProc1; 4665 } else if (strcmp(argv[2], "TestStatProc2") == 0) { 4666 proc = TestStatProc2; 4667 } else if (strcmp(argv[2], "TestStatProc3") == 0) { 4668 proc = TestStatProc3; 4669 } else { 4670 Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": ", 4671 "must be TclpStat, ", 4672 "TestStatProc1, TestStatProc2, or TestStatProc3", 4673 (char *) NULL); 4674 return TCL_ERROR; 4675 } 4676 4677 if (strcmp(argv[1], "insert") == 0) { 4678 if (proc == PretendTclpStat) { 4679 Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": ", 4680 "must be ", 4681 "TestStatProc1, TestStatProc2, or TestStatProc3", 4682 (char *) NULL); 4683 return TCL_ERROR; 4684 } 4685 retVal = TclStatInsertProc(proc); 4686 } else if (strcmp(argv[1], "delete") == 0) { 4687 retVal = TclStatDeleteProc(proc); 4688 } else { 4689 Tcl_AppendResult(interp, "bad option \"", argv[1], "\": ", 4690 "must be insert or delete", (char *) NULL); 4691 return TCL_ERROR; 4692 } 4693 4694 if (retVal == TCL_ERROR) { 4695 Tcl_AppendResult(interp, "\"", argv[2], "\": ", 4696 "could not be ", argv[1], "ed", (char *) NULL); 4697 } 4698 4699 return retVal; 4700} 4701 4702static int PretendTclpStat(path, buf) 4703 CONST char *path; 4704 struct stat *buf; 4705{ 4706 int ret; 4707 Tcl_Obj *pathPtr = Tcl_NewStringObj(path, -1); 4708#ifdef TCL_WIDE_INT_IS_LONG 4709 Tcl_IncrRefCount(pathPtr); 4710 ret = TclpObjStat(pathPtr, buf); 4711 Tcl_DecrRefCount(pathPtr); 4712 return ret; 4713#else /* TCL_WIDE_INT_IS_LONG */ 4714 Tcl_StatBuf realBuf; 4715 Tcl_IncrRefCount(pathPtr); 4716 ret = TclpObjStat(pathPtr, &realBuf); 4717 Tcl_DecrRefCount(pathPtr); 4718 if (ret != -1) { 4719# define OUT_OF_RANGE(x) \ 4720 (((Tcl_WideInt)(x)) < Tcl_LongAsWide(LONG_MIN) || \ 4721 ((Tcl_WideInt)(x)) > Tcl_LongAsWide(LONG_MAX)) 4722#if defined(__GNUC__) && __GNUC__ >= 2 4723/* 4724 * Workaround gcc warning of "comparison is always false due to limited range of 4725 * data type" in this macro by checking max type size, and when necessary ANDing 4726 * with the complement of ULONG_MAX instead of the comparison: 4727 */ 4728# define OUT_OF_URANGE(x) \ 4729 ((((Tcl_WideUInt)(~ (__typeof__(x)) 0)) > (Tcl_WideUInt)ULONG_MAX) && \ 4730 (((Tcl_WideUInt)(x)) & ~(Tcl_WideUInt)ULONG_MAX)) 4731#else 4732# define OUT_OF_URANGE(x) \ 4733 (((Tcl_WideUInt)(x)) > (Tcl_WideUInt)ULONG_MAX) 4734#endif 4735 4736 /* 4737 * Perform the result-buffer overflow check manually. 4738 * 4739 * Note that ino_t/ino64_t is unsigned... 4740 */ 4741 4742 if (OUT_OF_URANGE(realBuf.st_ino) || OUT_OF_RANGE(realBuf.st_size) 4743# ifdef HAVE_ST_BLOCKS 4744 || OUT_OF_RANGE(realBuf.st_blocks) 4745# endif 4746 ) { 4747# ifdef EOVERFLOW 4748 errno = EOVERFLOW; 4749# else 4750# ifdef EFBIG 4751 errno = EFBIG; 4752# else 4753# error "what error should be returned for a value out of range?" 4754# endif 4755# endif 4756 return -1; 4757 } 4758 4759# undef OUT_OF_RANGE 4760# undef OUT_OF_URANGE 4761 4762 /* 4763 * Copy across all supported fields, with possible type 4764 * coercions on those fields that change between the normal 4765 * and lf64 versions of the stat structure (on Solaris at 4766 * least.) This is slow when the structure sizes coincide, 4767 * but that's what you get for mixing interfaces... 4768 */ 4769 4770 buf->st_mode = realBuf.st_mode; 4771 buf->st_ino = (ino_t) realBuf.st_ino; 4772 buf->st_dev = realBuf.st_dev; 4773 buf->st_rdev = realBuf.st_rdev; 4774 buf->st_nlink = realBuf.st_nlink; 4775 buf->st_uid = realBuf.st_uid; 4776 buf->st_gid = realBuf.st_gid; 4777 buf->st_size = (off_t) realBuf.st_size; 4778 buf->st_atime = realBuf.st_atime; 4779 buf->st_mtime = realBuf.st_mtime; 4780 buf->st_ctime = realBuf.st_ctime; 4781# ifdef HAVE_ST_BLOCKS 4782 buf->st_blksize = realBuf.st_blksize; 4783 buf->st_blocks = (blkcnt_t) realBuf.st_blocks; 4784# endif 4785 } 4786 return ret; 4787#endif /* TCL_WIDE_INT_IS_LONG */ 4788} 4789 4790/* Be careful in the compares in these tests, since the Macintosh puts a 4791 * leading : in the beginning of non-absolute paths before passing them 4792 * into the file command procedures. 4793 */ 4794 4795static int 4796TestStatProc1(path, buf) 4797 CONST char *path; 4798 struct stat *buf; 4799{ 4800 memset(buf, 0, sizeof(struct stat)); 4801 buf->st_size = 1234; 4802 return ((strstr(path, "testStat1%.fil") == NULL) ? -1 : 0); 4803} 4804 4805 4806static int 4807TestStatProc2(path, buf) 4808 CONST char *path; 4809 struct stat *buf; 4810{ 4811 memset(buf, 0, sizeof(struct stat)); 4812 buf->st_size = 2345; 4813 return ((strstr(path, "testStat2%.fil") == NULL) ? -1 : 0); 4814} 4815 4816 4817static int 4818TestStatProc3(path, buf) 4819 CONST char *path; 4820 struct stat *buf; 4821{ 4822 memset(buf, 0, sizeof(struct stat)); 4823 buf->st_size = 3456; 4824 return ((strstr(path, "testStat3%.fil") == NULL) ? -1 : 0); 4825} 4826 4827/* 4828 *---------------------------------------------------------------------- 4829 * 4830 * TestmainthreadCmd -- 4831 * 4832 * Implements the "testmainthread" cmd that is used to test the 4833 * 'Tcl_GetCurrentThread' API. 4834 * 4835 * Results: 4836 * A standard Tcl result. 4837 * 4838 * Side effects: 4839 * None. 4840 * 4841 *---------------------------------------------------------------------- 4842 */ 4843 4844static int 4845TestmainthreadCmd (dummy, interp, argc, argv) 4846 ClientData dummy; /* Not used. */ 4847 register Tcl_Interp *interp; /* Current interpreter. */ 4848 int argc; /* Number of arguments. */ 4849 CONST char **argv; /* Argument strings. */ 4850{ 4851 if (argc == 1) { 4852 Tcl_Obj *idObj = Tcl_NewLongObj((long)Tcl_GetCurrentThread()); 4853 Tcl_SetObjResult(interp, idObj); 4854 return TCL_OK; 4855 } else { 4856 Tcl_SetResult(interp, "wrong # args", TCL_STATIC); 4857 return TCL_ERROR; 4858 } 4859} 4860 4861/* 4862 *---------------------------------------------------------------------- 4863 * 4864 * MainLoop -- 4865 * 4866 * A main loop set by TestsetmainloopCmd below. 4867 * 4868 * Results: 4869 * None. 4870 * 4871 * Side effects: 4872 * Event handlers could do anything. 4873 * 4874 *---------------------------------------------------------------------- 4875 */ 4876 4877static void 4878MainLoop(void) 4879{ 4880 while (!exitMainLoop) { 4881 Tcl_DoOneEvent(0); 4882 } 4883 fprintf(stdout,"Exit MainLoop\n"); 4884 fflush(stdout); 4885} 4886 4887/* 4888 *---------------------------------------------------------------------- 4889 * 4890 * TestsetmainloopCmd -- 4891 * 4892 * Implements the "testsetmainloop" cmd that is used to test the 4893 * 'Tcl_SetMainLoop' API. 4894 * 4895 * Results: 4896 * A standard Tcl result. 4897 * 4898 * Side effects: 4899 * None. 4900 * 4901 *---------------------------------------------------------------------- 4902 */ 4903 4904static int 4905TestsetmainloopCmd (dummy, interp, argc, argv) 4906 ClientData dummy; /* Not used. */ 4907 register Tcl_Interp *interp; /* Current interpreter. */ 4908 int argc; /* Number of arguments. */ 4909 CONST char **argv; /* Argument strings. */ 4910{ 4911 exitMainLoop = 0; 4912 Tcl_SetMainLoop(MainLoop); 4913 return TCL_OK; 4914} 4915 4916/* 4917 *---------------------------------------------------------------------- 4918 * 4919 * TestexitmainloopCmd -- 4920 * 4921 * Implements the "testexitmainloop" cmd that is used to test the 4922 * 'Tcl_SetMainLoop' API. 4923 * 4924 * Results: 4925 * A standard Tcl result. 4926 * 4927 * Side effects: 4928 * None. 4929 * 4930 *---------------------------------------------------------------------- 4931 */ 4932 4933static int 4934TestexitmainloopCmd (dummy, interp, argc, argv) 4935 ClientData dummy; /* Not used. */ 4936 register Tcl_Interp *interp; /* Current interpreter. */ 4937 int argc; /* Number of arguments. */ 4938 CONST char **argv; /* Argument strings. */ 4939{ 4940 exitMainLoop = 1; 4941 return TCL_OK; 4942} 4943 4944/* 4945 *---------------------------------------------------------------------- 4946 * 4947 * TestaccessprocCmd -- 4948 * 4949 * Implements the "testTclAccessProc" cmd that is used to test the 4950 * 'TclAccessInsertProc' & 'TclAccessDeleteProc' C Apis. 4951 * 4952 * Results: 4953 * A standard Tcl result. 4954 * 4955 * Side effects: 4956 * None. 4957 * 4958 *---------------------------------------------------------------------- 4959 */ 4960 4961static int 4962TestaccessprocCmd (dummy, interp, argc, argv) 4963 ClientData dummy; /* Not used. */ 4964 register Tcl_Interp *interp; /* Current interpreter. */ 4965 int argc; /* Number of arguments. */ 4966 CONST char **argv; /* Argument strings. */ 4967{ 4968 TclAccessProc_ *proc; 4969 int retVal; 4970 4971 if (argc != 3) { 4972 Tcl_AppendResult(interp, "wrong # args: should be \"", 4973 argv[0], " option arg\"", (char *) NULL); 4974 return TCL_ERROR; 4975 } 4976 4977 if (strcmp(argv[2], "TclpAccess") == 0) { 4978 proc = PretendTclpAccess; 4979 } else if (strcmp(argv[2], "TestAccessProc1") == 0) { 4980 proc = TestAccessProc1; 4981 } else if (strcmp(argv[2], "TestAccessProc2") == 0) { 4982 proc = TestAccessProc2; 4983 } else if (strcmp(argv[2], "TestAccessProc3") == 0) { 4984 proc = TestAccessProc3; 4985 } else { 4986 Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": ", 4987 "must be TclpAccess, ", 4988 "TestAccessProc1, TestAccessProc2, or TestAccessProc3", 4989 (char *) NULL); 4990 return TCL_ERROR; 4991 } 4992 4993 if (strcmp(argv[1], "insert") == 0) { 4994 if (proc == PretendTclpAccess) { 4995 Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": ", 4996 "must be ", 4997 "TestAccessProc1, TestAccessProc2, or TestAccessProc3", 4998 (char *) NULL); 4999 return TCL_ERROR; 5000 } 5001 retVal = TclAccessInsertProc(proc); 5002 } else if (strcmp(argv[1], "delete") == 0) { 5003 retVal = TclAccessDeleteProc(proc); 5004 } else { 5005 Tcl_AppendResult(interp, "bad option \"", argv[1], "\": ", 5006 "must be insert or delete", (char *) NULL); 5007 return TCL_ERROR; 5008 } 5009 5010 if (retVal == TCL_ERROR) { 5011 Tcl_AppendResult(interp, "\"", argv[2], "\": ", 5012 "could not be ", argv[1], "ed", (char *) NULL); 5013 } 5014 5015 return retVal; 5016} 5017 5018static int PretendTclpAccess(path, mode) 5019 CONST char *path; 5020 int mode; 5021{ 5022 int ret; 5023 Tcl_Obj *pathPtr = Tcl_NewStringObj(path, -1); 5024 Tcl_IncrRefCount(pathPtr); 5025 ret = TclpObjAccess(pathPtr, mode); 5026 Tcl_DecrRefCount(pathPtr); 5027 return ret; 5028} 5029 5030static int 5031TestAccessProc1(path, mode) 5032 CONST char *path; 5033 int mode; 5034{ 5035 return ((strstr(path, "testAccess1%.fil") == NULL) ? -1 : 0); 5036} 5037 5038 5039static int 5040TestAccessProc2(path, mode) 5041 CONST char *path; 5042 int mode; 5043{ 5044 return ((strstr(path, "testAccess2%.fil") == NULL) ? -1 : 0); 5045} 5046 5047 5048static int 5049TestAccessProc3(path, mode) 5050 CONST char *path; 5051 int mode; 5052{ 5053 return ((strstr(path, "testAccess3%.fil") == NULL) ? -1 : 0); 5054} 5055 5056/* 5057 *---------------------------------------------------------------------- 5058 * 5059 * TestopenfilechannelprocCmd -- 5060 * 5061 * Implements the "testTclOpenFileChannelProc" cmd that is used to test the 5062 * 'TclOpenFileChannelInsertProc' & 'TclOpenFileChannelDeleteProc' C Apis. 5063 * 5064 * Results: 5065 * A standard Tcl result. 5066 * 5067 * Side effects: 5068 * None. 5069 * 5070 *---------------------------------------------------------------------- 5071 */ 5072 5073static int 5074TestopenfilechannelprocCmd (dummy, interp, argc, argv) 5075 ClientData dummy; /* Not used. */ 5076 register Tcl_Interp *interp; /* Current interpreter. */ 5077 int argc; /* Number of arguments. */ 5078 CONST char **argv; /* Argument strings. */ 5079{ 5080 TclOpenFileChannelProc_ *proc; 5081 int retVal; 5082 5083 if (argc != 3) { 5084 Tcl_AppendResult(interp, "wrong # args: should be \"", 5085 argv[0], " option arg\"", (char *) NULL); 5086 return TCL_ERROR; 5087 } 5088 5089 if (strcmp(argv[2], "TclpOpenFileChannel") == 0) { 5090 proc = PretendTclpOpenFileChannel; 5091 } else if (strcmp(argv[2], "TestOpenFileChannelProc1") == 0) { 5092 proc = TestOpenFileChannelProc1; 5093 } else if (strcmp(argv[2], "TestOpenFileChannelProc2") == 0) { 5094 proc = TestOpenFileChannelProc2; 5095 } else if (strcmp(argv[2], "TestOpenFileChannelProc3") == 0) { 5096 proc = TestOpenFileChannelProc3; 5097 } else { 5098 Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": ", 5099 "must be TclpOpenFileChannel, ", 5100 "TestOpenFileChannelProc1, TestOpenFileChannelProc2, or ", 5101 "TestOpenFileChannelProc3", 5102 (char *) NULL); 5103 return TCL_ERROR; 5104 } 5105 5106 if (strcmp(argv[1], "insert") == 0) { 5107 if (proc == PretendTclpOpenFileChannel) { 5108 Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": ", 5109 "must be ", 5110 "TestOpenFileChannelProc1, TestOpenFileChannelProc2, or ", 5111 "TestOpenFileChannelProc3", 5112 (char *) NULL); 5113 return TCL_ERROR; 5114 } 5115 retVal = TclOpenFileChannelInsertProc(proc); 5116 } else if (strcmp(argv[1], "delete") == 0) { 5117 retVal = TclOpenFileChannelDeleteProc(proc); 5118 } else { 5119 Tcl_AppendResult(interp, "bad option \"", argv[1], "\": ", 5120 "must be insert or delete", (char *) NULL); 5121 return TCL_ERROR; 5122 } 5123 5124 if (retVal == TCL_ERROR) { 5125 Tcl_AppendResult(interp, "\"", argv[2], "\": ", 5126 "could not be ", argv[1], "ed", (char *) NULL); 5127 } 5128 5129 return retVal; 5130} 5131 5132static Tcl_Channel 5133PretendTclpOpenFileChannel(interp, fileName, modeString, permissions) 5134 Tcl_Interp *interp; /* Interpreter for error reporting; 5135 * can be NULL. */ 5136 CONST char *fileName; /* Name of file to open. */ 5137 CONST char *modeString; /* A list of POSIX open modes or 5138 * a string such as "rw". */ 5139 int permissions; /* If the open involves creating a 5140 * file, with what modes to create 5141 * it? */ 5142{ 5143 Tcl_Channel ret; 5144 int mode, seekFlag; 5145 Tcl_Obj *pathPtr; 5146 mode = TclGetOpenMode(interp, modeString, &seekFlag); 5147 if (mode == -1) { 5148 return NULL; 5149 } 5150 pathPtr = Tcl_NewStringObj(fileName, -1); 5151 Tcl_IncrRefCount(pathPtr); 5152 ret = TclpOpenFileChannel(interp, pathPtr, mode, permissions); 5153 Tcl_DecrRefCount(pathPtr); 5154 if (ret != NULL) { 5155 if (seekFlag) { 5156 if (Tcl_Seek(ret, (Tcl_WideInt)0, SEEK_END) < (Tcl_WideInt)0) { 5157 if (interp != (Tcl_Interp *) NULL) { 5158 Tcl_AppendResult(interp, 5159 "could not seek to end of file while opening \"", 5160 fileName, "\": ", 5161 Tcl_PosixError(interp), (char *) NULL); 5162 } 5163 Tcl_Close(NULL, ret); 5164 return NULL; 5165 } 5166 } 5167 } 5168 return ret; 5169} 5170 5171static Tcl_Channel 5172TestOpenFileChannelProc1(interp, fileName, modeString, permissions) 5173 Tcl_Interp *interp; /* Interpreter for error reporting; 5174 * can be NULL. */ 5175 CONST char *fileName; /* Name of file to open. */ 5176 CONST char *modeString; /* A list of POSIX open modes or 5177 * a string such as "rw". */ 5178 int permissions; /* If the open involves creating a 5179 * file, with what modes to create 5180 * it? */ 5181{ 5182 CONST char *expectname="testOpenFileChannel1%.fil"; 5183 Tcl_DString ds; 5184 5185 Tcl_DStringInit(&ds); 5186 Tcl_JoinPath(1, &expectname, &ds); 5187 5188 if (!strcmp(Tcl_DStringValue(&ds), fileName)) { 5189 Tcl_DStringFree(&ds); 5190 return (PretendTclpOpenFileChannel(interp, "__testOpenFileChannel1%__.fil", 5191 modeString, permissions)); 5192 } else { 5193 Tcl_DStringFree(&ds); 5194 return (NULL); 5195 } 5196} 5197 5198 5199static Tcl_Channel 5200TestOpenFileChannelProc2(interp, fileName, modeString, permissions) 5201 Tcl_Interp *interp; /* Interpreter for error reporting; 5202 * can be NULL. */ 5203 CONST char *fileName; /* Name of file to open. */ 5204 CONST char *modeString; /* A list of POSIX open modes or 5205 * a string such as "rw". */ 5206 int permissions; /* If the open involves creating a 5207 * file, with what modes to create 5208 * it? */ 5209{ 5210 CONST char *expectname="testOpenFileChannel2%.fil"; 5211 Tcl_DString ds; 5212 5213 Tcl_DStringInit(&ds); 5214 Tcl_JoinPath(1, &expectname, &ds); 5215 5216 if (!strcmp(Tcl_DStringValue(&ds), fileName)) { 5217 Tcl_DStringFree(&ds); 5218 return (PretendTclpOpenFileChannel(interp, "__testOpenFileChannel2%__.fil", 5219 modeString, permissions)); 5220 } else { 5221 Tcl_DStringFree(&ds); 5222 return (NULL); 5223 } 5224} 5225 5226 5227static Tcl_Channel 5228TestOpenFileChannelProc3(interp, fileName, modeString, permissions) 5229 Tcl_Interp *interp; /* Interpreter for error reporting; 5230 * can be NULL. */ 5231 CONST char *fileName; /* Name of file to open. */ 5232 CONST char *modeString; /* A list of POSIX open modes or 5233 * a string such as "rw". */ 5234 int permissions; /* If the open involves creating a 5235 * file, with what modes to create 5236 * it? */ 5237{ 5238 CONST char *expectname="testOpenFileChannel3%.fil"; 5239 Tcl_DString ds; 5240 5241 Tcl_DStringInit(&ds); 5242 Tcl_JoinPath(1, &expectname, &ds); 5243 5244 if (!strcmp(Tcl_DStringValue(&ds), fileName)) { 5245 Tcl_DStringFree(&ds); 5246 return (PretendTclpOpenFileChannel(interp, "__testOpenFileChannel3%__.fil", 5247 modeString, permissions)); 5248 } else { 5249 Tcl_DStringFree(&ds); 5250 return (NULL); 5251 } 5252} 5253 5254/* 5255 *---------------------------------------------------------------------- 5256 * 5257 * TestChannelCmd -- 5258 * 5259 * Implements the Tcl "testchannel" debugging command and its 5260 * subcommands. This is part of the testing environment. 5261 * 5262 * Results: 5263 * A standard Tcl result. 5264 * 5265 * Side effects: 5266 * None. 5267 * 5268 *---------------------------------------------------------------------- 5269 */ 5270 5271 /* ARGSUSED */ 5272static int 5273TestChannelCmd(clientData, interp, argc, argv) 5274 ClientData clientData; /* Not used. */ 5275 Tcl_Interp *interp; /* Interpreter for result. */ 5276 int argc; /* Count of additional args. */ 5277 CONST char **argv; /* Additional arg strings. */ 5278{ 5279 CONST char *cmdName; /* Sub command. */ 5280 Tcl_HashTable *hTblPtr; /* Hash table of channels. */ 5281 Tcl_HashSearch hSearch; /* Search variable. */ 5282 Tcl_HashEntry *hPtr; /* Search variable. */ 5283 Channel *chanPtr; /* The actual channel. */ 5284 ChannelState *statePtr; /* state info for channel */ 5285 Tcl_Channel chan; /* The opaque type. */ 5286 size_t len; /* Length of subcommand string. */ 5287 int IOQueued; /* How much IO is queued inside channel? */ 5288 ChannelBuffer *bufPtr; /* For iterating over queued IO. */ 5289 char buf[TCL_INTEGER_SPACE];/* For sprintf. */ 5290 int mode; /* rw mode of the channel */ 5291 5292 if (argc < 2) { 5293 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], 5294 " subcommand ?additional args..?\"", (char *) NULL); 5295 return TCL_ERROR; 5296 } 5297 cmdName = argv[1]; 5298 len = strlen(cmdName); 5299 5300 chanPtr = (Channel *) NULL; 5301 5302 if (argc > 2) { 5303 chan = Tcl_GetChannel(interp, argv[2], &mode); 5304 if (chan == (Tcl_Channel) NULL) { 5305 return TCL_ERROR; 5306 } 5307 chanPtr = (Channel *) chan; 5308 statePtr = chanPtr->state; 5309 chanPtr = statePtr->topChanPtr; 5310 chan = (Tcl_Channel) chanPtr; 5311 } else { 5312 /* lint */ 5313 statePtr = NULL; 5314 chan = NULL; 5315 } 5316 5317 if ((cmdName[0] == 'c') && (strncmp(cmdName, "cut", len) == 0)) { 5318 if (argc != 3) { 5319 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], 5320 " cut channelName\"", (char *) NULL); 5321 return TCL_ERROR; 5322 } 5323 Tcl_CutChannel(chan); 5324 return TCL_OK; 5325 } 5326 5327 if ((cmdName[0] == 'c') && 5328 (strncmp(cmdName, "clearchannelhandlers", len) == 0)) { 5329 if (argc != 3) { 5330 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], 5331 " clearchannelhandlers channelName\"", (char *) NULL); 5332 return TCL_ERROR; 5333 } 5334 Tcl_ClearChannelHandlers(chan); 5335 return TCL_OK; 5336 } 5337 5338 if ((cmdName[0] == 'i') && (strncmp(cmdName, "info", len) == 0)) { 5339 if (argc != 3) { 5340 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], 5341 " info channelName\"", (char *) NULL); 5342 return TCL_ERROR; 5343 } 5344 Tcl_AppendElement(interp, argv[2]); 5345 Tcl_AppendElement(interp, Tcl_ChannelName(chanPtr->typePtr)); 5346 if (statePtr->flags & TCL_READABLE) { 5347 Tcl_AppendElement(interp, "read"); 5348 } else { 5349 Tcl_AppendElement(interp, ""); 5350 } 5351 if (statePtr->flags & TCL_WRITABLE) { 5352 Tcl_AppendElement(interp, "write"); 5353 } else { 5354 Tcl_AppendElement(interp, ""); 5355 } 5356 if (statePtr->flags & CHANNEL_NONBLOCKING) { 5357 Tcl_AppendElement(interp, "nonblocking"); 5358 } else { 5359 Tcl_AppendElement(interp, "blocking"); 5360 } 5361 if (statePtr->flags & CHANNEL_LINEBUFFERED) { 5362 Tcl_AppendElement(interp, "line"); 5363 } else if (statePtr->flags & CHANNEL_UNBUFFERED) { 5364 Tcl_AppendElement(interp, "none"); 5365 } else { 5366 Tcl_AppendElement(interp, "full"); 5367 } 5368 if (statePtr->flags & BG_FLUSH_SCHEDULED) { 5369 Tcl_AppendElement(interp, "async_flush"); 5370 } else { 5371 Tcl_AppendElement(interp, ""); 5372 } 5373 if (statePtr->flags & CHANNEL_EOF) { 5374 Tcl_AppendElement(interp, "eof"); 5375 } else { 5376 Tcl_AppendElement(interp, ""); 5377 } 5378 if (statePtr->flags & CHANNEL_BLOCKED) { 5379 Tcl_AppendElement(interp, "blocked"); 5380 } else { 5381 Tcl_AppendElement(interp, "unblocked"); 5382 } 5383 if (statePtr->inputTranslation == TCL_TRANSLATE_AUTO) { 5384 Tcl_AppendElement(interp, "auto"); 5385 if (statePtr->flags & INPUT_SAW_CR) { 5386 Tcl_AppendElement(interp, "saw_cr"); 5387 } else { 5388 Tcl_AppendElement(interp, ""); 5389 } 5390 } else if (statePtr->inputTranslation == TCL_TRANSLATE_LF) { 5391 Tcl_AppendElement(interp, "lf"); 5392 Tcl_AppendElement(interp, ""); 5393 } else if (statePtr->inputTranslation == TCL_TRANSLATE_CR) { 5394 Tcl_AppendElement(interp, "cr"); 5395 Tcl_AppendElement(interp, ""); 5396 } else if (statePtr->inputTranslation == TCL_TRANSLATE_CRLF) { 5397 Tcl_AppendElement(interp, "crlf"); 5398 if (statePtr->flags & INPUT_SAW_CR) { 5399 Tcl_AppendElement(interp, "queued_cr"); 5400 } else { 5401 Tcl_AppendElement(interp, ""); 5402 } 5403 } 5404 if (statePtr->outputTranslation == TCL_TRANSLATE_AUTO) { 5405 Tcl_AppendElement(interp, "auto"); 5406 } else if (statePtr->outputTranslation == TCL_TRANSLATE_LF) { 5407 Tcl_AppendElement(interp, "lf"); 5408 } else if (statePtr->outputTranslation == TCL_TRANSLATE_CR) { 5409 Tcl_AppendElement(interp, "cr"); 5410 } else if (statePtr->outputTranslation == TCL_TRANSLATE_CRLF) { 5411 Tcl_AppendElement(interp, "crlf"); 5412 } 5413 for (IOQueued = 0, bufPtr = statePtr->inQueueHead; 5414 bufPtr != (ChannelBuffer *) NULL; 5415 bufPtr = bufPtr->nextPtr) { 5416 IOQueued += bufPtr->nextAdded - bufPtr->nextRemoved; 5417 } 5418 TclFormatInt(buf, IOQueued); 5419 Tcl_AppendElement(interp, buf); 5420 5421 IOQueued = 0; 5422 if (statePtr->curOutPtr != (ChannelBuffer *) NULL) { 5423 IOQueued = statePtr->curOutPtr->nextAdded - 5424 statePtr->curOutPtr->nextRemoved; 5425 } 5426 for (bufPtr = statePtr->outQueueHead; 5427 bufPtr != (ChannelBuffer *) NULL; 5428 bufPtr = bufPtr->nextPtr) { 5429 IOQueued += (bufPtr->nextAdded - bufPtr->nextRemoved); 5430 } 5431 TclFormatInt(buf, IOQueued); 5432 Tcl_AppendElement(interp, buf); 5433 5434 TclFormatInt(buf, (int)Tcl_Tell((Tcl_Channel) chanPtr)); 5435 Tcl_AppendElement(interp, buf); 5436 5437 TclFormatInt(buf, statePtr->refCount); 5438 Tcl_AppendElement(interp, buf); 5439 5440 return TCL_OK; 5441 } 5442 5443 if ((cmdName[0] == 'i') && 5444 (strncmp(cmdName, "inputbuffered", len) == 0)) { 5445 if (argc != 3) { 5446 Tcl_AppendResult(interp, "channel name required", 5447 (char *) NULL); 5448 return TCL_ERROR; 5449 } 5450 5451 for (IOQueued = 0, bufPtr = statePtr->inQueueHead; 5452 bufPtr != (ChannelBuffer *) NULL; 5453 bufPtr = bufPtr->nextPtr) { 5454 IOQueued += bufPtr->nextAdded - bufPtr->nextRemoved; 5455 } 5456 TclFormatInt(buf, IOQueued); 5457 Tcl_AppendResult(interp, buf, (char *) NULL); 5458 return TCL_OK; 5459 } 5460 5461 if ((cmdName[0] == 'i') && (strncmp(cmdName, "isshared", len) == 0)) { 5462 if (argc != 3) { 5463 Tcl_AppendResult(interp, "channel name required", (char *) NULL); 5464 return TCL_ERROR; 5465 } 5466 5467 TclFormatInt(buf, Tcl_IsChannelShared(chan)); 5468 Tcl_AppendResult(interp, buf, (char *) NULL); 5469 return TCL_OK; 5470 } 5471 5472 if ((cmdName[0] == 'i') && (strncmp(cmdName, "isstandard", len) == 0)) { 5473 if (argc != 3) { 5474 Tcl_AppendResult(interp, "channel name required", (char *) NULL); 5475 return TCL_ERROR; 5476 } 5477 5478 TclFormatInt(buf, Tcl_IsStandardChannel(chan)); 5479 Tcl_AppendResult(interp, buf, (char *) NULL); 5480 return TCL_OK; 5481 } 5482 5483 if ((cmdName[0] == 'm') && (strncmp(cmdName, "mode", len) == 0)) { 5484 if (argc != 3) { 5485 Tcl_AppendResult(interp, "channel name required", 5486 (char *) NULL); 5487 return TCL_ERROR; 5488 } 5489 5490 if (statePtr->flags & TCL_READABLE) { 5491 Tcl_AppendElement(interp, "read"); 5492 } else { 5493 Tcl_AppendElement(interp, ""); 5494 } 5495 if (statePtr->flags & TCL_WRITABLE) { 5496 Tcl_AppendElement(interp, "write"); 5497 } else { 5498 Tcl_AppendElement(interp, ""); 5499 } 5500 return TCL_OK; 5501 } 5502 5503 if ((cmdName[0] == 'm') && (strncmp(cmdName, "mthread", len) == 0)) { 5504 if (argc != 3) { 5505 Tcl_AppendResult(interp, "channel name required", 5506 (char *) NULL); 5507 return TCL_ERROR; 5508 } 5509 5510 TclFormatInt(buf, (long) Tcl_GetChannelThread(chan)); 5511 Tcl_AppendResult(interp, buf, (char *) NULL); 5512 return TCL_OK; 5513 } 5514 5515 if ((cmdName[0] == 'n') && (strncmp(cmdName, "name", len) == 0)) { 5516 if (argc != 3) { 5517 Tcl_AppendResult(interp, "channel name required", 5518 (char *) NULL); 5519 return TCL_ERROR; 5520 } 5521 Tcl_AppendResult(interp, statePtr->channelName, (char *) NULL); 5522 return TCL_OK; 5523 } 5524 5525 if ((cmdName[0] == 'o') && (strncmp(cmdName, "open", len) == 0)) { 5526 hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL); 5527 if (hTblPtr == (Tcl_HashTable *) NULL) { 5528 return TCL_OK; 5529 } 5530 for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); 5531 hPtr != (Tcl_HashEntry *) NULL; 5532 hPtr = Tcl_NextHashEntry(&hSearch)) { 5533 Tcl_AppendElement(interp, Tcl_GetHashKey(hTblPtr, hPtr)); 5534 } 5535 return TCL_OK; 5536 } 5537 5538 if ((cmdName[0] == 'o') && 5539 (strncmp(cmdName, "outputbuffered", len) == 0)) { 5540 if (argc != 3) { 5541 Tcl_AppendResult(interp, "channel name required", 5542 (char *) NULL); 5543 return TCL_ERROR; 5544 } 5545 5546 IOQueued = 0; 5547 if (statePtr->curOutPtr != (ChannelBuffer *) NULL) { 5548 IOQueued = statePtr->curOutPtr->nextAdded - 5549 statePtr->curOutPtr->nextRemoved; 5550 } 5551 for (bufPtr = statePtr->outQueueHead; 5552 bufPtr != (ChannelBuffer *) NULL; 5553 bufPtr = bufPtr->nextPtr) { 5554 IOQueued += (bufPtr->nextAdded - bufPtr->nextRemoved); 5555 } 5556 TclFormatInt(buf, IOQueued); 5557 Tcl_AppendResult(interp, buf, (char *) NULL); 5558 return TCL_OK; 5559 } 5560 5561 if ((cmdName[0] == 'q') && 5562 (strncmp(cmdName, "queuedcr", len) == 0)) { 5563 if (argc != 3) { 5564 Tcl_AppendResult(interp, "channel name required", 5565 (char *) NULL); 5566 return TCL_ERROR; 5567 } 5568 5569 Tcl_AppendResult(interp, 5570 (statePtr->flags & INPUT_SAW_CR) ? "1" : "0", 5571 (char *) NULL); 5572 return TCL_OK; 5573 } 5574 5575 if ((cmdName[0] == 'r') && (strncmp(cmdName, "readable", len) == 0)) { 5576 hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL); 5577 if (hTblPtr == (Tcl_HashTable *) NULL) { 5578 return TCL_OK; 5579 } 5580 for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); 5581 hPtr != (Tcl_HashEntry *) NULL; 5582 hPtr = Tcl_NextHashEntry(&hSearch)) { 5583 chanPtr = (Channel *) Tcl_GetHashValue(hPtr); 5584 statePtr = chanPtr->state; 5585 if (statePtr->flags & TCL_READABLE) { 5586 Tcl_AppendElement(interp, Tcl_GetHashKey(hTblPtr, hPtr)); 5587 } 5588 } 5589 return TCL_OK; 5590 } 5591 5592 if ((cmdName[0] == 'r') && (strncmp(cmdName, "refcount", len) == 0)) { 5593 if (argc != 3) { 5594 Tcl_AppendResult(interp, "channel name required", 5595 (char *) NULL); 5596 return TCL_ERROR; 5597 } 5598 5599 TclFormatInt(buf, statePtr->refCount); 5600 Tcl_AppendResult(interp, buf, (char *) NULL); 5601 return TCL_OK; 5602 } 5603 5604 if ((cmdName[0] == 's') && (strncmp(cmdName, "splice", len) == 0)) { 5605 if (argc != 3) { 5606 Tcl_AppendResult(interp, "channel name required", (char *) NULL); 5607 return TCL_ERROR; 5608 } 5609 5610 Tcl_SpliceChannel(chan); 5611 return TCL_OK; 5612 } 5613 5614 if ((cmdName[0] == 't') && (strncmp(cmdName, "type", len) == 0)) { 5615 if (argc != 3) { 5616 Tcl_AppendResult(interp, "channel name required", 5617 (char *) NULL); 5618 return TCL_ERROR; 5619 } 5620 Tcl_AppendResult(interp, Tcl_ChannelName(chanPtr->typePtr), 5621 (char *) NULL); 5622 return TCL_OK; 5623 } 5624 5625 if ((cmdName[0] == 'w') && (strncmp(cmdName, "writable", len) == 0)) { 5626 hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL); 5627 if (hTblPtr == (Tcl_HashTable *) NULL) { 5628 return TCL_OK; 5629 } 5630 for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); 5631 hPtr != (Tcl_HashEntry *) NULL; 5632 hPtr = Tcl_NextHashEntry(&hSearch)) { 5633 chanPtr = (Channel *) Tcl_GetHashValue(hPtr); 5634 statePtr = chanPtr->state; 5635 if (statePtr->flags & TCL_WRITABLE) { 5636 Tcl_AppendElement(interp, Tcl_GetHashKey(hTblPtr, hPtr)); 5637 } 5638 } 5639 return TCL_OK; 5640 } 5641 5642 if ((cmdName[0] == 't') && (strncmp(cmdName, "transform", len) == 0)) { 5643 /* 5644 * Syntax: transform channel -command command 5645 */ 5646 5647 if (argc != 5) { 5648 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], 5649 " transform channelId -command cmd\"", (char *) NULL); 5650 return TCL_ERROR; 5651 } 5652 if (strcmp(argv[3], "-command") != 0) { 5653 Tcl_AppendResult(interp, "bad argument \"", argv[3], 5654 "\": should be \"-command\"", (char *) NULL); 5655 return TCL_ERROR; 5656 } 5657 5658 return TclChannelTransform(interp, chan, 5659 Tcl_NewStringObj(argv[4], -1)); 5660 } 5661 5662 if ((cmdName[0] == 'u') && (strncmp(cmdName, "unstack", len) == 0)) { 5663 /* 5664 * Syntax: unstack channel 5665 */ 5666 5667 if (argc != 3) { 5668 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], 5669 " unstack channel\"", (char *) NULL); 5670 return TCL_ERROR; 5671 } 5672 return Tcl_UnstackChannel(interp, chan); 5673 } 5674 5675 Tcl_AppendResult(interp, "bad option \"", cmdName, "\": should be ", 5676 "cut, clearchannelhandlers, info, isshared, mode, open, " 5677 "readable, splice, writable, transform, unstack", 5678 (char *) NULL); 5679 return TCL_ERROR; 5680} 5681 5682/* 5683 *---------------------------------------------------------------------- 5684 * 5685 * TestChannelEventCmd -- 5686 * 5687 * This procedure implements the "testchannelevent" command. It is 5688 * used to test the Tcl channel event mechanism. 5689 * 5690 * Results: 5691 * A standard Tcl result. 5692 * 5693 * Side effects: 5694 * Creates, deletes and returns channel event handlers. 5695 * 5696 *---------------------------------------------------------------------- 5697 */ 5698 5699 /* ARGSUSED */ 5700static int 5701TestChannelEventCmd(dummy, interp, argc, argv) 5702 ClientData dummy; /* Not used. */ 5703 Tcl_Interp *interp; /* Current interpreter. */ 5704 int argc; /* Number of arguments. */ 5705 CONST char **argv; /* Argument strings. */ 5706{ 5707 Tcl_Obj *resultListPtr; 5708 Channel *chanPtr; 5709 ChannelState *statePtr; /* state info for channel */ 5710 EventScriptRecord *esPtr, *prevEsPtr, *nextEsPtr; 5711 CONST char *cmd; 5712 int index, i, mask, len; 5713 5714 if ((argc < 3) || (argc > 5)) { 5715 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], 5716 " channelName cmd ?arg1? ?arg2?\"", (char *) NULL); 5717 return TCL_ERROR; 5718 } 5719 chanPtr = (Channel *) Tcl_GetChannel(interp, argv[1], NULL); 5720 if (chanPtr == (Channel *) NULL) { 5721 return TCL_ERROR; 5722 } 5723 statePtr = chanPtr->state; 5724 5725 cmd = argv[2]; 5726 len = strlen(cmd); 5727 if ((cmd[0] == 'a') && (strncmp(cmd, "add", (unsigned) len) == 0)) { 5728 if (argc != 5) { 5729 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], 5730 " channelName add eventSpec script\"", (char *) NULL); 5731 return TCL_ERROR; 5732 } 5733 if (strcmp(argv[3], "readable") == 0) { 5734 mask = TCL_READABLE; 5735 } else if (strcmp(argv[3], "writable") == 0) { 5736 mask = TCL_WRITABLE; 5737 } else if (strcmp(argv[3], "none") == 0) { 5738 mask = 0; 5739 } else { 5740 Tcl_AppendResult(interp, "bad event name \"", argv[3], 5741 "\": must be readable, writable, or none", (char *) NULL); 5742 return TCL_ERROR; 5743 } 5744 5745 esPtr = (EventScriptRecord *) ckalloc((unsigned) 5746 sizeof(EventScriptRecord)); 5747 esPtr->nextPtr = statePtr->scriptRecordPtr; 5748 statePtr->scriptRecordPtr = esPtr; 5749 5750 esPtr->chanPtr = chanPtr; 5751 esPtr->interp = interp; 5752 esPtr->mask = mask; 5753 esPtr->scriptPtr = Tcl_NewStringObj(argv[4], -1); 5754 Tcl_IncrRefCount(esPtr->scriptPtr); 5755 5756 Tcl_CreateChannelHandler((Tcl_Channel) chanPtr, mask, 5757 TclChannelEventScriptInvoker, (ClientData) esPtr); 5758 5759 return TCL_OK; 5760 } 5761 5762 if ((cmd[0] == 'd') && (strncmp(cmd, "delete", (unsigned) len) == 0)) { 5763 if (argc != 4) { 5764 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], 5765 " channelName delete index\"", (char *) NULL); 5766 return TCL_ERROR; 5767 } 5768 if (Tcl_GetInt(interp, argv[3], &index) == TCL_ERROR) { 5769 return TCL_ERROR; 5770 } 5771 if (index < 0) { 5772 Tcl_AppendResult(interp, "bad event index: ", argv[3], 5773 ": must be nonnegative", (char *) NULL); 5774 return TCL_ERROR; 5775 } 5776 for (i = 0, esPtr = statePtr->scriptRecordPtr; 5777 (i < index) && (esPtr != (EventScriptRecord *) NULL); 5778 i++, esPtr = esPtr->nextPtr) { 5779 /* Empty loop body. */ 5780 } 5781 if (esPtr == (EventScriptRecord *) NULL) { 5782 Tcl_AppendResult(interp, "bad event index ", argv[3], 5783 ": out of range", (char *) NULL); 5784 return TCL_ERROR; 5785 } 5786 if (esPtr == statePtr->scriptRecordPtr) { 5787 statePtr->scriptRecordPtr = esPtr->nextPtr; 5788 } else { 5789 for (prevEsPtr = statePtr->scriptRecordPtr; 5790 (prevEsPtr != (EventScriptRecord *) NULL) && 5791 (prevEsPtr->nextPtr != esPtr); 5792 prevEsPtr = prevEsPtr->nextPtr) { 5793 /* Empty loop body. */ 5794 } 5795 if (prevEsPtr == (EventScriptRecord *) NULL) { 5796 panic("TestChannelEventCmd: damaged event script list"); 5797 } 5798 prevEsPtr->nextPtr = esPtr->nextPtr; 5799 } 5800 Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr, 5801 TclChannelEventScriptInvoker, (ClientData) esPtr); 5802 Tcl_DecrRefCount(esPtr->scriptPtr); 5803 ckfree((char *) esPtr); 5804 5805 return TCL_OK; 5806 } 5807 5808 if ((cmd[0] == 'l') && (strncmp(cmd, "list", (unsigned) len) == 0)) { 5809 if (argc != 3) { 5810 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], 5811 " channelName list\"", (char *) NULL); 5812 return TCL_ERROR; 5813 } 5814 resultListPtr = Tcl_GetObjResult(interp); 5815 for (esPtr = statePtr->scriptRecordPtr; 5816 esPtr != (EventScriptRecord *) NULL; 5817 esPtr = esPtr->nextPtr) { 5818 if (esPtr->mask) { 5819 Tcl_ListObjAppendElement(interp, resultListPtr, Tcl_NewStringObj( 5820 (esPtr->mask == TCL_READABLE) ? "readable" : "writable", -1)); 5821 } else { 5822 Tcl_ListObjAppendElement(interp, resultListPtr, 5823 Tcl_NewStringObj("none", -1)); 5824 } 5825 Tcl_ListObjAppendElement(interp, resultListPtr, esPtr->scriptPtr); 5826 } 5827 Tcl_SetObjResult(interp, resultListPtr); 5828 return TCL_OK; 5829 } 5830 5831 if ((cmd[0] == 'r') && (strncmp(cmd, "removeall", (unsigned) len) == 0)) { 5832 if (argc != 3) { 5833 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], 5834 " channelName removeall\"", (char *) NULL); 5835 return TCL_ERROR; 5836 } 5837 for (esPtr = statePtr->scriptRecordPtr; 5838 esPtr != (EventScriptRecord *) NULL; 5839 esPtr = nextEsPtr) { 5840 nextEsPtr = esPtr->nextPtr; 5841 Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr, 5842 TclChannelEventScriptInvoker, (ClientData) esPtr); 5843 Tcl_DecrRefCount(esPtr->scriptPtr); 5844 ckfree((char *) esPtr); 5845 } 5846 statePtr->scriptRecordPtr = (EventScriptRecord *) NULL; 5847 return TCL_OK; 5848 } 5849 5850 if ((cmd[0] == 's') && (strncmp(cmd, "set", (unsigned) len) == 0)) { 5851 if (argc != 5) { 5852 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], 5853 " channelName delete index event\"", (char *) NULL); 5854 return TCL_ERROR; 5855 } 5856 if (Tcl_GetInt(interp, argv[3], &index) == TCL_ERROR) { 5857 return TCL_ERROR; 5858 } 5859 if (index < 0) { 5860 Tcl_AppendResult(interp, "bad event index: ", argv[3], 5861 ": must be nonnegative", (char *) NULL); 5862 return TCL_ERROR; 5863 } 5864 for (i = 0, esPtr = statePtr->scriptRecordPtr; 5865 (i < index) && (esPtr != (EventScriptRecord *) NULL); 5866 i++, esPtr = esPtr->nextPtr) { 5867 /* Empty loop body. */ 5868 } 5869 if (esPtr == (EventScriptRecord *) NULL) { 5870 Tcl_AppendResult(interp, "bad event index ", argv[3], 5871 ": out of range", (char *) NULL); 5872 return TCL_ERROR; 5873 } 5874 5875 if (strcmp(argv[4], "readable") == 0) { 5876 mask = TCL_READABLE; 5877 } else if (strcmp(argv[4], "writable") == 0) { 5878 mask = TCL_WRITABLE; 5879 } else if (strcmp(argv[4], "none") == 0) { 5880 mask = 0; 5881 } else { 5882 Tcl_AppendResult(interp, "bad event name \"", argv[4], 5883 "\": must be readable, writable, or none", (char *) NULL); 5884 return TCL_ERROR; 5885 } 5886 esPtr->mask = mask; 5887 Tcl_CreateChannelHandler((Tcl_Channel) chanPtr, mask, 5888 TclChannelEventScriptInvoker, (ClientData) esPtr); 5889 return TCL_OK; 5890 } 5891 Tcl_AppendResult(interp, "bad command ", cmd, ", must be one of ", 5892 "add, delete, list, set, or removeall", (char *) NULL); 5893 return TCL_ERROR; 5894} 5895 5896/* 5897 *---------------------------------------------------------------------- 5898 * 5899 * TestWrongNumArgsObjCmd -- 5900 * 5901 * Test the Tcl_WrongNumArgs function. 5902 * 5903 * Results: 5904 * Standard Tcl result. 5905 * 5906 * Side effects: 5907 * Sets interpreter result. 5908 * 5909 *---------------------------------------------------------------------- 5910 */ 5911 5912static int 5913TestWrongNumArgsObjCmd(dummy, interp, objc, objv) 5914 ClientData dummy; /* Not used. */ 5915 Tcl_Interp *interp; /* Current interpreter. */ 5916 int objc; /* Number of arguments. */ 5917 Tcl_Obj *CONST objv[]; /* Argument objects. */ 5918{ 5919 int i, length; 5920 char *msg; 5921 5922 if (objc < 3) { 5923 /* 5924 * Don't use Tcl_WrongNumArgs here, as that is the function 5925 * we want to test! 5926 */ 5927 Tcl_SetResult(interp, "insufficient arguments", TCL_STATIC); 5928 return TCL_ERROR; 5929 } 5930 5931 if (Tcl_GetIntFromObj(interp, objv[1], &i) != TCL_OK) { 5932 return TCL_ERROR; 5933 } 5934 5935 msg = Tcl_GetStringFromObj(objv[2], &length); 5936 if (length == 0) { 5937 msg = NULL; 5938 } 5939 5940 if (i > objc - 3) { 5941 /* 5942 * Asked for more arguments than were given. 5943 */ 5944 Tcl_SetResult(interp, "insufficient arguments", TCL_STATIC); 5945 return TCL_ERROR; 5946 } 5947 5948 Tcl_WrongNumArgs(interp, i, &(objv[3]), msg); 5949 return TCL_OK; 5950} 5951 5952/* 5953 *---------------------------------------------------------------------- 5954 * 5955 * TestGetIndexFromObjStructObjCmd -- 5956 * 5957 * Test the Tcl_GetIndexFromObjStruct function. 5958 * 5959 * Results: 5960 * Standard Tcl result. 5961 * 5962 * Side effects: 5963 * Sets interpreter result. 5964 * 5965 *---------------------------------------------------------------------- 5966 */ 5967 5968static int 5969TestGetIndexFromObjStructObjCmd(dummy, interp, objc, objv) 5970 ClientData dummy; /* Not used. */ 5971 Tcl_Interp *interp; /* Current interpreter. */ 5972 int objc; /* Number of arguments. */ 5973 Tcl_Obj *CONST objv[]; /* Argument objects. */ 5974{ 5975 char *ary[] = { 5976 "a", "b", "c", "d", "e", "f", (char *)NULL,(char *)NULL 5977 }; 5978 int idx,target; 5979 5980 if (objc != 3) { 5981 Tcl_WrongNumArgs(interp, 1, objv, "argument targetvalue"); 5982 return TCL_ERROR; 5983 } 5984 if (Tcl_GetIndexFromObjStruct(interp, objv[1], ary, 2*sizeof(char *), 5985 "dummy", 0, &idx) != TCL_OK) { 5986 return TCL_ERROR; 5987 } 5988 if (Tcl_GetIntFromObj(interp, objv[2], &target) != TCL_OK) { 5989 return TCL_ERROR; 5990 } 5991 if (idx != target) { 5992 char buffer[64]; 5993 sprintf(buffer, "%d", idx); 5994 Tcl_AppendResult(interp, "index value comparison failed: got ", 5995 buffer, NULL); 5996 sprintf(buffer, "%d", target); 5997 Tcl_AppendResult(interp, " when ", buffer, " expected", NULL); 5998 return TCL_ERROR; 5999 } 6000 Tcl_WrongNumArgs(interp, 3, objv, NULL); 6001 return TCL_OK; 6002} 6003 6004/* 6005 *---------------------------------------------------------------------- 6006 * 6007 * TestFilesystemObjCmd -- 6008 * 6009 * This procedure implements the "testfilesystem" command. It is 6010 * used to test Tcl_FSRegister, Tcl_FSUnregister, and can be used 6011 * to test that the pluggable filesystem works. 6012 * 6013 * Results: 6014 * A standard Tcl result. 6015 * 6016 * Side effects: 6017 * Inserts or removes a filesystem from Tcl's stack. 6018 * 6019 *---------------------------------------------------------------------- 6020 */ 6021 6022static int 6023TestFilesystemObjCmd(dummy, interp, objc, objv) 6024 ClientData dummy; 6025 Tcl_Interp *interp; 6026 int objc; 6027 Tcl_Obj *CONST objv[]; 6028{ 6029 int res, boolVal; 6030 char *msg; 6031 6032 if (objc != 2) { 6033 Tcl_WrongNumArgs(interp, 1, objv, "boolean"); 6034 return TCL_ERROR; 6035 } 6036 if (Tcl_GetBooleanFromObj(interp, objv[1], &boolVal) != TCL_OK) { 6037 return TCL_ERROR; 6038 } 6039 if (boolVal) { 6040 res = Tcl_FSRegister((ClientData)interp, &testReportingFilesystem); 6041 msg = (res == TCL_OK) ? "registered" : "failed"; 6042 } else { 6043 res = Tcl_FSUnregister(&testReportingFilesystem); 6044 msg = (res == TCL_OK) ? "unregistered" : "failed"; 6045 } 6046 Tcl_SetResult(interp, msg, TCL_VOLATILE); 6047 return res; 6048} 6049 6050static int 6051TestReportInFilesystem(Tcl_Obj *pathPtr, ClientData *clientDataPtr) 6052{ 6053 static Tcl_Obj* lastPathPtr = NULL; 6054 6055 if (pathPtr == lastPathPtr) { 6056 /* Reject all files second time around */ 6057 return -1; 6058 } else { 6059 Tcl_Obj * newPathPtr; 6060 /* Try to claim all files first time around */ 6061 6062 newPathPtr = Tcl_DuplicateObj(pathPtr); 6063 lastPathPtr = newPathPtr; 6064 Tcl_IncrRefCount(newPathPtr); 6065 if (Tcl_FSGetFileSystemForPath(newPathPtr) == NULL) { 6066 /* Nothing claimed it. Therefore we don't either */ 6067 Tcl_DecrRefCount(newPathPtr); 6068 lastPathPtr = NULL; 6069 return -1; 6070 } else { 6071 lastPathPtr = NULL; 6072 *clientDataPtr = (ClientData) newPathPtr; 6073 return TCL_OK; 6074 } 6075 } 6076} 6077 6078/* 6079 * Simple helper function to extract the native vfs representation of a 6080 * path object, or NULL if no such representation exists. 6081 */ 6082static Tcl_Obj* 6083TestReportGetNativePath(Tcl_Obj* pathObjPtr) { 6084 return (Tcl_Obj*) Tcl_FSGetInternalRep(pathObjPtr, &testReportingFilesystem); 6085} 6086 6087static void 6088TestReportFreeInternalRep(ClientData clientData) { 6089 Tcl_Obj *nativeRep = (Tcl_Obj*)clientData; 6090 if (nativeRep != NULL) { 6091 /* Free the path */ 6092 Tcl_DecrRefCount(nativeRep); 6093 } 6094} 6095 6096static ClientData 6097TestReportDupInternalRep(ClientData clientData) { 6098 Tcl_Obj *original = (Tcl_Obj*)clientData; 6099 Tcl_IncrRefCount(original); 6100 return clientData; 6101} 6102 6103static void 6104TestReport(cmd, path, arg2) 6105 CONST char* cmd; 6106 Tcl_Obj* path; 6107 Tcl_Obj* arg2; 6108{ 6109 Tcl_Interp* interp = (Tcl_Interp*) Tcl_FSData(&testReportingFilesystem); 6110 if (interp == NULL) { 6111 /* This is bad, but not much we can do about it */ 6112 } else { 6113 /* 6114 * No idea why I decided to program this up using the 6115 * old string-based API, but there you go. We should 6116 * convert it to objects. 6117 */ 6118 Tcl_SavedResult savedResult; 6119 Tcl_DString ds; 6120 Tcl_DStringInit(&ds); 6121 Tcl_DStringAppend(&ds, "lappend filesystemReport ",-1); 6122 Tcl_DStringStartSublist(&ds); 6123 Tcl_DStringAppendElement(&ds, cmd); 6124 if (path != NULL) { 6125 Tcl_DStringAppendElement(&ds, Tcl_GetString(path)); 6126 } 6127 if (arg2 != NULL) { 6128 Tcl_DStringAppendElement(&ds, Tcl_GetString(arg2)); 6129 } 6130 Tcl_DStringEndSublist(&ds); 6131 Tcl_SaveResult(interp, &savedResult); 6132 Tcl_Eval(interp, Tcl_DStringValue(&ds)); 6133 Tcl_DStringFree(&ds); 6134 Tcl_RestoreResult(interp, &savedResult); 6135 } 6136} 6137 6138static int 6139TestReportStat(path, buf) 6140 Tcl_Obj *path; /* Path of file to stat (in current CP). */ 6141 Tcl_StatBuf *buf; /* Filled with results of stat call. */ 6142{ 6143 TestReport("stat",path, NULL); 6144 return Tcl_FSStat(TestReportGetNativePath(path),buf); 6145} 6146static int 6147TestReportLstat(path, buf) 6148 Tcl_Obj *path; /* Path of file to stat (in current CP). */ 6149 Tcl_StatBuf *buf; /* Filled with results of stat call. */ 6150{ 6151 TestReport("lstat",path, NULL); 6152 return Tcl_FSLstat(TestReportGetNativePath(path),buf); 6153} 6154static int 6155TestReportAccess(path, mode) 6156 Tcl_Obj *path; /* Path of file to access (in current CP). */ 6157 int mode; /* Permission setting. */ 6158{ 6159 TestReport("access",path,NULL); 6160 return Tcl_FSAccess(TestReportGetNativePath(path),mode); 6161} 6162static Tcl_Channel 6163TestReportOpenFileChannel(interp, fileName, mode, permissions) 6164 Tcl_Interp *interp; /* Interpreter for error reporting; 6165 * can be NULL. */ 6166 Tcl_Obj *fileName; /* Name of file to open. */ 6167 int mode; /* POSIX open mode. */ 6168 int permissions; /* If the open involves creating a 6169 * file, with what modes to create 6170 * it? */ 6171{ 6172 TestReport("open",fileName, NULL); 6173 return TclpOpenFileChannel(interp, TestReportGetNativePath(fileName), 6174 mode, permissions); 6175} 6176 6177static int 6178TestReportMatchInDirectory(interp, resultPtr, dirPtr, pattern, types) 6179 Tcl_Interp *interp; /* Interpreter to receive results. */ 6180 Tcl_Obj *resultPtr; /* Object to lappend results. */ 6181 Tcl_Obj *dirPtr; /* Contains path to directory to search. */ 6182 CONST char *pattern; /* Pattern to match against. */ 6183 Tcl_GlobTypeData *types; /* Object containing list of acceptable types. 6184 * May be NULL. */ 6185{ 6186 if (types != NULL && types->type & TCL_GLOB_TYPE_MOUNT) { 6187 TestReport("matchmounts",dirPtr, NULL); 6188 return TCL_OK; 6189 } else { 6190 TestReport("matchindirectory",dirPtr, NULL); 6191 return Tcl_FSMatchInDirectory(interp, resultPtr, 6192 TestReportGetNativePath(dirPtr), pattern, 6193 types); 6194 } 6195} 6196static int 6197TestReportChdir(dirName) 6198 Tcl_Obj *dirName; 6199{ 6200 TestReport("chdir",dirName,NULL); 6201 return Tcl_FSChdir(TestReportGetNativePath(dirName)); 6202} 6203static int 6204TestReportLoadFile(interp, fileName, 6205 handlePtr, unloadProcPtr) 6206 Tcl_Interp *interp; /* Used for error reporting. */ 6207 Tcl_Obj *fileName; /* Name of the file containing the desired 6208 * code. */ 6209 Tcl_LoadHandle *handlePtr; /* Filled with token for dynamically loaded 6210 * file which will be passed back to 6211 * (*unloadProcPtr)() to unload the file. */ 6212 Tcl_FSUnloadFileProc **unloadProcPtr; 6213 /* Filled with address of Tcl_FSUnloadFileProc 6214 * function which should be used for 6215 * this file. */ 6216{ 6217 TestReport("loadfile",fileName,NULL); 6218 return Tcl_FSLoadFile(interp, TestReportGetNativePath(fileName), NULL, NULL, 6219 NULL, NULL, handlePtr, unloadProcPtr); 6220} 6221static Tcl_Obj * 6222TestReportLink(path, to, linkType) 6223 Tcl_Obj *path; /* Path of file to readlink or link */ 6224 Tcl_Obj *to; /* Path of file to link to, or NULL */ 6225 int linkType; 6226{ 6227 TestReport("link",path,to); 6228 return Tcl_FSLink(TestReportGetNativePath(path), to, linkType); 6229} 6230static int 6231TestReportRenameFile(src, dst) 6232 Tcl_Obj *src; /* Pathname of file or dir to be renamed 6233 * (UTF-8). */ 6234 Tcl_Obj *dst; /* New pathname of file or directory 6235 * (UTF-8). */ 6236{ 6237 TestReport("renamefile",src,dst); 6238 return Tcl_FSRenameFile(TestReportGetNativePath(src), 6239 TestReportGetNativePath(dst)); 6240} 6241static int 6242TestReportCopyFile(src, dst) 6243 Tcl_Obj *src; /* Pathname of file to be copied (UTF-8). */ 6244 Tcl_Obj *dst; /* Pathname of file to copy to (UTF-8). */ 6245{ 6246 TestReport("copyfile",src,dst); 6247 return Tcl_FSCopyFile(TestReportGetNativePath(src), 6248 TestReportGetNativePath(dst)); 6249} 6250static int 6251TestReportDeleteFile(path) 6252 Tcl_Obj *path; /* Pathname of file to be removed (UTF-8). */ 6253{ 6254 TestReport("deletefile",path,NULL); 6255 return Tcl_FSDeleteFile(TestReportGetNativePath(path)); 6256} 6257static int 6258TestReportCreateDirectory(path) 6259 Tcl_Obj *path; /* Pathname of directory to create (UTF-8). */ 6260{ 6261 TestReport("createdirectory",path,NULL); 6262 return Tcl_FSCreateDirectory(TestReportGetNativePath(path)); 6263} 6264static int 6265TestReportCopyDirectory(src, dst, errorPtr) 6266 Tcl_Obj *src; /* Pathname of directory to be copied 6267 * (UTF-8). */ 6268 Tcl_Obj *dst; /* Pathname of target directory (UTF-8). */ 6269 Tcl_Obj **errorPtr; /* If non-NULL, to be filled with UTF-8 name 6270 * of file causing error. */ 6271{ 6272 TestReport("copydirectory",src,dst); 6273 return Tcl_FSCopyDirectory(TestReportGetNativePath(src), 6274 TestReportGetNativePath(dst), errorPtr); 6275} 6276static int 6277TestReportRemoveDirectory(path, recursive, errorPtr) 6278 Tcl_Obj *path; /* Pathname of directory to be removed 6279 * (UTF-8). */ 6280 int recursive; /* If non-zero, removes directories that 6281 * are nonempty. Otherwise, will only remove 6282 * empty directories. */ 6283 Tcl_Obj **errorPtr; /* If non-NULL, to be filled with UTF-8 name 6284 * of file causing error. */ 6285{ 6286 TestReport("removedirectory",path,NULL); 6287 return Tcl_FSRemoveDirectory(TestReportGetNativePath(path), recursive, 6288 errorPtr); 6289} 6290static CONST char** 6291TestReportFileAttrStrings(fileName, objPtrRef) 6292 Tcl_Obj* fileName; 6293 Tcl_Obj** objPtrRef; 6294{ 6295 TestReport("fileattributestrings",fileName,NULL); 6296 return Tcl_FSFileAttrStrings(TestReportGetNativePath(fileName), objPtrRef); 6297} 6298static int 6299TestReportFileAttrsGet(interp, index, fileName, objPtrRef) 6300 Tcl_Interp *interp; /* The interpreter for error reporting. */ 6301 int index; /* index of the attribute command. */ 6302 Tcl_Obj *fileName; /* filename we are operating on. */ 6303 Tcl_Obj **objPtrRef; /* for output. */ 6304{ 6305 TestReport("fileattributesget",fileName,NULL); 6306 return Tcl_FSFileAttrsGet(interp, index, 6307 TestReportGetNativePath(fileName), objPtrRef); 6308} 6309static int 6310TestReportFileAttrsSet(interp, index, fileName, objPtr) 6311 Tcl_Interp *interp; /* The interpreter for error reporting. */ 6312 int index; /* index of the attribute command. */ 6313 Tcl_Obj *fileName; /* filename we are operating on. */ 6314 Tcl_Obj *objPtr; /* for input. */ 6315{ 6316 TestReport("fileattributesset",fileName,objPtr); 6317 return Tcl_FSFileAttrsSet(interp, index, 6318 TestReportGetNativePath(fileName), objPtr); 6319} 6320static int 6321TestReportUtime (fileName, tval) 6322 Tcl_Obj* fileName; 6323 struct utimbuf *tval; 6324{ 6325 TestReport("utime",fileName,NULL); 6326 return Tcl_FSUtime(TestReportGetNativePath(fileName), tval); 6327} 6328static int 6329TestReportNormalizePath(interp, pathPtr, nextCheckpoint) 6330 Tcl_Interp *interp; 6331 Tcl_Obj *pathPtr; 6332 int nextCheckpoint; 6333{ 6334 TestReport("normalizepath",pathPtr,NULL); 6335 return nextCheckpoint; 6336} 6337 6338static int 6339SimplePathInFilesystem(Tcl_Obj *pathPtr, ClientData *clientDataPtr) { 6340 CONST char *str = Tcl_GetString(pathPtr); 6341 if (strncmp(str,"simplefs:/",10)) { 6342 return -1; 6343 } 6344 return TCL_OK; 6345} 6346 6347/* 6348 * Since TclCopyChannel insists on an interpreter, we use this 6349 * to simplify our test scripts. Would be better if it could 6350 * copy without an interp 6351 */ 6352static Tcl_Interp *simpleInterpPtr = NULL; 6353/* We use this to ensure we clean up after ourselves */ 6354static Tcl_Obj *tempFile = NULL; 6355 6356/* 6357 * This is a very 'hacky' filesystem which is used just to 6358 * test two important features of the vfs code: (1) that 6359 * you can load a shared library from a vfs, (2) that when 6360 * copying files from one fs to another, the 'mtime' is 6361 * preserved. 6362 * 6363 * It treats any file in 'simplefs:/' as a file, and 6364 * artificially creates a real file on the fly which it uses 6365 * to extract information from. The real file it uses is 6366 * whatever follows the trailing '/' (e.g. 'foo' in 'simplefs:/foo'), 6367 * and that file is assumed to exist in the native pwd, and is 6368 * copied over to the native temporary directory where it is 6369 * accessed. 6370 * 6371 * Please do not consider this filesystem a model of how 6372 * things are to be done. It is quite the opposite! But, it 6373 * does allow us to test two important features. 6374 * 6375 * Finally: this fs can only be used from one interpreter. 6376 */ 6377static int 6378TestSimpleFilesystemObjCmd(dummy, interp, objc, objv) 6379 ClientData dummy; 6380 Tcl_Interp *interp; 6381 int objc; 6382 Tcl_Obj *CONST objv[]; 6383{ 6384 int res, boolVal; 6385 char *msg; 6386 6387 if (objc != 2) { 6388 Tcl_WrongNumArgs(interp, 1, objv, "boolean"); 6389 return TCL_ERROR; 6390 } 6391 if (Tcl_GetBooleanFromObj(interp, objv[1], &boolVal) != TCL_OK) { 6392 return TCL_ERROR; 6393 } 6394 if (boolVal) { 6395 res = Tcl_FSRegister((ClientData)interp, &simpleFilesystem); 6396 msg = (res == TCL_OK) ? "registered" : "failed"; 6397 simpleInterpPtr = interp; 6398 } else { 6399 if (tempFile != NULL) { 6400 Tcl_FSDeleteFile(tempFile); 6401 Tcl_DecrRefCount(tempFile); 6402 tempFile = NULL; 6403 } 6404 res = Tcl_FSUnregister(&simpleFilesystem); 6405 msg = (res == TCL_OK) ? "unregistered" : "failed"; 6406 simpleInterpPtr = NULL; 6407 } 6408 Tcl_SetResult(interp, msg, TCL_VOLATILE); 6409 return res; 6410} 6411 6412/* 6413 * Treats a file name 'simplefs:/foo' by copying the file 'foo' 6414 * in the current (native) directory to a temporary native file, 6415 * and then returns that native file. 6416 */ 6417static Tcl_Obj* 6418SimpleCopy(pathPtr) 6419 Tcl_Obj *pathPtr; /* Name of file to copy. */ 6420{ 6421 int res; 6422 CONST char *str; 6423 Tcl_Obj *origPtr; 6424 Tcl_Obj *tempPtr; 6425 6426 tempPtr = TclpTempFileName(); 6427 Tcl_IncrRefCount(tempPtr); 6428 6429 /* 6430 * We assume the same name in the current directory is ok. 6431 */ 6432 str = Tcl_GetString(pathPtr); 6433 origPtr = Tcl_NewStringObj(str+10,-1); 6434 Tcl_IncrRefCount(origPtr); 6435 6436 res = TclCrossFilesystemCopy(simpleInterpPtr, origPtr, tempPtr); 6437 Tcl_DecrRefCount(origPtr); 6438 6439 if (res != TCL_OK) { 6440 Tcl_FSDeleteFile(tempPtr); 6441 Tcl_DecrRefCount(tempPtr); 6442 return NULL; 6443 } 6444 return tempPtr; 6445} 6446 6447static Tcl_Channel 6448SimpleOpenFileChannel(interp, pathPtr, mode, permissions) 6449 Tcl_Interp *interp; /* Interpreter for error reporting; 6450 * can be NULL. */ 6451 Tcl_Obj *pathPtr; /* Name of file to open. */ 6452 int mode; /* POSIX open mode. */ 6453 int permissions; /* If the open involves creating a 6454 * file, with what modes to create 6455 * it? */ 6456{ 6457 Tcl_Obj *tempPtr; 6458 Tcl_Channel chan; 6459 6460 if ((mode != 0) && !(mode & O_RDONLY)) { 6461 Tcl_AppendResult(interp, "read-only", 6462 (char *) NULL); 6463 return NULL; 6464 } 6465 6466 tempPtr = SimpleCopy(pathPtr); 6467 6468 if (tempPtr == NULL) { 6469 return NULL; 6470 } 6471 6472 chan = Tcl_FSOpenFileChannel(interp, tempPtr, "r", permissions); 6473 6474 if (tempFile != NULL) { 6475 Tcl_FSDeleteFile(tempFile); 6476 Tcl_DecrRefCount(tempFile); 6477 tempFile = NULL; 6478 } 6479 /* 6480 * Store file pointer in this global variable so we can delete 6481 * it later 6482 */ 6483 tempFile = tempPtr; 6484 return chan; 6485} 6486 6487static int 6488SimpleAccess(pathPtr, mode) 6489 Tcl_Obj *pathPtr; /* Path of file to access (in current CP). */ 6490 int mode; /* Permission setting. */ 6491{ 6492 /* All files exist */ 6493 return TCL_OK; 6494} 6495 6496static int 6497SimpleStat(pathPtr, bufPtr) 6498 Tcl_Obj *pathPtr; /* Path of file to stat (in current CP). */ 6499 Tcl_StatBuf *bufPtr; /* Filled with results of stat call. */ 6500{ 6501 Tcl_Obj *tempPtr = SimpleCopy(pathPtr); 6502 if (tempPtr == NULL) { 6503 /* We just pretend the file exists anyway */ 6504 return TCL_OK; 6505 } else { 6506 int res = Tcl_FSStat(tempPtr, bufPtr); 6507 Tcl_FSDeleteFile(tempPtr); 6508 Tcl_DecrRefCount(tempPtr); 6509 return res; 6510 } 6511} 6512 6513static Tcl_Obj* 6514SimpleListVolumes(void) 6515{ 6516 /* Add one new volume */ 6517 Tcl_Obj *retVal; 6518 6519 retVal = Tcl_NewStringObj("simplefs:/",-1); 6520 Tcl_IncrRefCount(retVal); 6521 return retVal; 6522} 6523 6524/* 6525 * Used to check correct string-length determining in Tcl_NumUtfChars 6526 */ 6527static int 6528TestNumUtfCharsCmd(clientData, interp, objc, objv) 6529 ClientData clientData; 6530 Tcl_Interp *interp; 6531 int objc; 6532 Tcl_Obj *CONST objv[]; 6533{ 6534 if (objc > 1) { 6535 int len = -1; 6536 if (objc > 2) { 6537 (void) Tcl_GetStringFromObj(objv[1], &len); 6538 } 6539 len = Tcl_NumUtfChars(Tcl_GetString(objv[1]), len); 6540 Tcl_SetObjResult(interp, Tcl_NewIntObj(len)); 6541 } 6542 return TCL_OK; 6543} 6544