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