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