1 /*
2 * tclTestObj.c --
3 *
4 * This file contains C command functions for the additional Tcl commands
5 * that are used for testing implementations of the Tcl object types.
6 * These commands are not normally included in Tcl applications; they're
7 * only used for testing.
8 *
9 * Copyright (c) 1995-1998 Sun Microsystems, Inc.
10 * Copyright (c) 1999 by Scriptics Corporation.
11 * Copyright (c) 2005 by Kevin B. Kenny. All rights reserved.
12 *
13 * See the file "license.terms" for information on usage and redistribution of
14 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
15 */
16
17 #include "tclInt.h"
18 #include "tommath.h"
19
20 /*
21 * An array of Tcl_Obj pointers used in the commands that operate on or get
22 * the values of Tcl object-valued variables. varPtr[i] is the i-th variable's
23 * Tcl_Obj *.
24 */
25
26 #define NUMBER_OF_OBJECT_VARS 20
27 static Tcl_Obj *varPtr[NUMBER_OF_OBJECT_VARS];
28
29 /*
30 * Forward declarations for functions defined later in this file:
31 */
32
33 static int CheckIfVarUnset(Tcl_Interp *interp, int varIndex);
34 static int GetVariableIndex(Tcl_Interp *interp,
35 const char *string, int *indexPtr);
36 static void SetVarToObj(int varIndex, Tcl_Obj *objPtr);
37 int TclObjTest_Init(Tcl_Interp *interp);
38 static int TestbignumobjCmd(ClientData dummy, Tcl_Interp *interp,
39 int objc, Tcl_Obj *const objv[]);
40 static int TestbooleanobjCmd(ClientData dummy,
41 Tcl_Interp *interp, int objc,
42 Tcl_Obj *const objv[]);
43 static int TestdoubleobjCmd(ClientData dummy, Tcl_Interp *interp,
44 int objc, Tcl_Obj *const objv[]);
45 static int TestindexobjCmd(ClientData dummy, Tcl_Interp *interp,
46 int objc, Tcl_Obj *const objv[]);
47 static int TestintobjCmd(ClientData dummy, Tcl_Interp *interp,
48 int objc, Tcl_Obj *const objv[]);
49 static int TestlistobjCmd(ClientData dummy, Tcl_Interp *interp,
50 int objc, Tcl_Obj *const objv[]);
51 static int TestobjCmd(ClientData dummy, Tcl_Interp *interp,
52 int objc, Tcl_Obj *const objv[]);
53 static int TeststringobjCmd(ClientData dummy, Tcl_Interp *interp,
54 int objc, Tcl_Obj *const objv[]);
55
56 typedef struct TestString {
57 int numChars;
58 size_t allocated;
59 size_t uallocated;
60 Tcl_UniChar unicode[2];
61 } TestString;
62
63 /*
64 *----------------------------------------------------------------------
65 *
66 * TclObjTest_Init --
67 *
68 * This function creates additional commands that are used to test the
69 * Tcl object support.
70 *
71 * Results:
72 * Returns a standard Tcl completion code, and leaves an error
73 * message in the interp's result if an error occurs.
74 *
75 * Side effects:
76 * Creates and registers several new testing commands.
77 *
78 *----------------------------------------------------------------------
79 */
80
81 int
TclObjTest_Init(Tcl_Interp * interp)82 TclObjTest_Init(
83 Tcl_Interp *interp)
84 {
85 register int i;
86
87 for (i = 0; i < NUMBER_OF_OBJECT_VARS; i++) {
88 varPtr[i] = NULL;
89 }
90
91 Tcl_CreateObjCommand(interp, "testbignumobj", TestbignumobjCmd,
92 (ClientData) 0, NULL);
93 Tcl_CreateObjCommand(interp, "testbooleanobj", TestbooleanobjCmd,
94 (ClientData) 0, NULL);
95 Tcl_CreateObjCommand(interp, "testdoubleobj", TestdoubleobjCmd,
96 (ClientData) 0, NULL);
97 Tcl_CreateObjCommand(interp, "testintobj", TestintobjCmd,
98 (ClientData) 0, NULL);
99 Tcl_CreateObjCommand(interp, "testindexobj", TestindexobjCmd,
100 (ClientData) 0, NULL);
101 Tcl_CreateObjCommand(interp, "testlistobj", TestlistobjCmd,
102 (ClientData) 0, NULL);
103 Tcl_CreateObjCommand(interp, "testobj", TestobjCmd, (ClientData) 0, NULL);
104 Tcl_CreateObjCommand(interp, "teststringobj", TeststringobjCmd,
105 (ClientData) 0, NULL);
106 return TCL_OK;
107 }
108
109 /*
110 *----------------------------------------------------------------------
111 *
112 * TestbignumobjCmd --
113 *
114 * This function implmenets the "testbignumobj" command. It is used
115 * to exercise the bignum Tcl object type implementation.
116 *
117 * Results:
118 * Returns a standard Tcl object result.
119 *
120 * Side effects:
121 * Creates and frees bignum objects; converts objects to have bignum
122 * type.
123 *
124 *----------------------------------------------------------------------
125 */
126
127 static int
TestbignumobjCmd(ClientData clientData,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])128 TestbignumobjCmd(
129 ClientData clientData, /* unused */
130 Tcl_Interp *interp, /* Tcl interpreter */
131 int objc, /* Argument count */
132 Tcl_Obj *const objv[]) /* Argument vector */
133 {
134 const char * subcmds[] = {
135 "set", "get", "mult10", "div10", NULL
136 };
137 enum options {
138 BIGNUM_SET, BIGNUM_GET, BIGNUM_MULT10, BIGNUM_DIV10
139 };
140
141 int index, varIndex;
142 char* string;
143 mp_int bignumValue, newValue;
144
145 if (objc < 3) {
146 Tcl_WrongNumArgs(interp, 1, objv, "option ?arg?...");
147 return TCL_ERROR;
148 }
149 if (Tcl_GetIndexFromObj(interp, objv[1], subcmds, "option", 0,
150 &index) != TCL_OK) {
151 return TCL_ERROR;
152 }
153 string = Tcl_GetString(objv[2]);
154 if (GetVariableIndex(interp, string, &varIndex) != TCL_OK) {
155 return TCL_ERROR;
156 }
157
158 switch (index) {
159 case BIGNUM_SET:
160 if (objc != 4) {
161 Tcl_WrongNumArgs(interp, 2, objv, "var value");
162 return TCL_ERROR;
163 }
164 string = Tcl_GetString(objv[3]);
165 if (mp_init(&bignumValue) != MP_OKAY) {
166 Tcl_SetObjResult(interp,
167 Tcl_NewStringObj("error in mp_init", -1));
168 return TCL_ERROR;
169 }
170 if (mp_read_radix(&bignumValue, string, 10) != MP_OKAY) {
171 mp_clear(&bignumValue);
172 Tcl_SetObjResult(interp,
173 Tcl_NewStringObj("error in mp_read_radix", -1));
174 return TCL_ERROR;
175 }
176
177 /*
178 * If the object currently bound to the variable with index varIndex
179 * has ref count 1 (i.e. the object is unshared) we can modify that
180 * object directly. Otherwise, if RC>1 (i.e. the object is shared),
181 * we must create a new object to modify/set and decrement the old
182 * formerly-shared object's ref count. This is "copy on write".
183 */
184
185 if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
186 Tcl_SetBignumObj(varPtr[varIndex], &bignumValue);
187 } else {
188 SetVarToObj(varIndex, Tcl_NewBignumObj(&bignumValue));
189 }
190 break;
191
192 case BIGNUM_GET:
193 if (objc != 3) {
194 Tcl_WrongNumArgs(interp, 2, objv, "varIndex");
195 return TCL_ERROR;
196 }
197 if (CheckIfVarUnset(interp, varIndex)) {
198 return TCL_ERROR;
199 }
200 break;
201
202 case BIGNUM_MULT10:
203 if (objc != 3) {
204 Tcl_WrongNumArgs(interp, 2, objv, "varIndex");
205 return TCL_ERROR;
206 }
207 if (CheckIfVarUnset(interp, varIndex)) {
208 return TCL_ERROR;
209 }
210 if (Tcl_GetBignumFromObj(interp, varPtr[varIndex],
211 &bignumValue) != TCL_OK) {
212 return TCL_ERROR;
213 }
214 if (mp_init(&newValue) != MP_OKAY
215 || (mp_mul_d(&bignumValue, 10, &newValue) != MP_OKAY)) {
216 mp_clear(&bignumValue);
217 mp_clear(&newValue);
218 Tcl_SetObjResult(interp,
219 Tcl_NewStringObj("error in mp_mul_d", -1));
220 return TCL_ERROR;
221 }
222 mp_clear(&bignumValue);
223 if (!Tcl_IsShared(varPtr[varIndex])) {
224 Tcl_SetBignumObj(varPtr[varIndex], &newValue);
225 } else {
226 SetVarToObj(varIndex, Tcl_NewBignumObj(&newValue));
227 }
228 break;
229
230 case BIGNUM_DIV10:
231 if (objc != 3) {
232 Tcl_WrongNumArgs(interp, 2, objv, "varIndex");
233 return TCL_ERROR;
234 }
235 if (CheckIfVarUnset(interp, varIndex)) {
236 return TCL_ERROR;
237 }
238 if (Tcl_GetBignumFromObj(interp, varPtr[varIndex],
239 &bignumValue) != TCL_OK) {
240 return TCL_ERROR;
241 }
242 if (mp_init(&newValue) != MP_OKAY
243 || (mp_div_d(&bignumValue, 10, &newValue, NULL) != MP_OKAY)) {
244 mp_clear(&bignumValue);
245 mp_clear(&newValue);
246 Tcl_SetObjResult(interp,
247 Tcl_NewStringObj("error in mp_div_d", -1));
248 return TCL_ERROR;
249 }
250 mp_clear(&bignumValue);
251 if (!Tcl_IsShared(varPtr[varIndex])) {
252 Tcl_SetBignumObj(varPtr[varIndex], &newValue);
253 } else {
254 SetVarToObj(varIndex, Tcl_NewBignumObj(&newValue));
255 }
256 }
257
258 Tcl_SetObjResult(interp, varPtr[varIndex]);
259 return TCL_OK;
260 }
261
262 /*
263 *----------------------------------------------------------------------
264 *
265 * TestbooleanobjCmd --
266 *
267 * This function implements the "testbooleanobj" command. It is used to
268 * test the boolean Tcl object type implementation.
269 *
270 * Results:
271 * A standard Tcl object result.
272 *
273 * Side effects:
274 * Creates and frees boolean objects, and also converts objects to
275 * have boolean type.
276 *
277 *----------------------------------------------------------------------
278 */
279
280 static int
TestbooleanobjCmd(ClientData clientData,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])281 TestbooleanobjCmd(
282 ClientData clientData, /* Not used. */
283 Tcl_Interp *interp, /* Current interpreter. */
284 int objc, /* Number of arguments. */
285 Tcl_Obj *const objv[]) /* Argument objects. */
286 {
287 int varIndex, boolValue;
288 char *index, *subCmd;
289
290 if (objc < 3) {
291 wrongNumArgs:
292 Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");
293 return TCL_ERROR;
294 }
295
296 index = Tcl_GetString(objv[2]);
297 if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
298 return TCL_ERROR;
299 }
300
301 subCmd = Tcl_GetString(objv[1]);
302 if (strcmp(subCmd, "set") == 0) {
303 if (objc != 4) {
304 goto wrongNumArgs;
305 }
306 if (Tcl_GetBooleanFromObj(interp, objv[3], &boolValue) != TCL_OK) {
307 return TCL_ERROR;
308 }
309
310 /*
311 * If the object currently bound to the variable with index varIndex
312 * has ref count 1 (i.e. the object is unshared) we can modify that
313 * object directly. Otherwise, if RC>1 (i.e. the object is shared),
314 * we must create a new object to modify/set and decrement the old
315 * formerly-shared object's ref count. This is "copy on write".
316 */
317
318 if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
319 Tcl_SetBooleanObj(varPtr[varIndex], boolValue);
320 } else {
321 SetVarToObj(varIndex, Tcl_NewBooleanObj(boolValue));
322 }
323 Tcl_SetObjResult(interp, varPtr[varIndex]);
324 } else if (strcmp(subCmd, "get") == 0) {
325 if (objc != 3) {
326 goto wrongNumArgs;
327 }
328 if (CheckIfVarUnset(interp, varIndex)) {
329 return TCL_ERROR;
330 }
331 Tcl_SetObjResult(interp, varPtr[varIndex]);
332 } else if (strcmp(subCmd, "not") == 0) {
333 if (objc != 3) {
334 goto wrongNumArgs;
335 }
336 if (CheckIfVarUnset(interp, varIndex)) {
337 return TCL_ERROR;
338 }
339 if (Tcl_GetBooleanFromObj(interp, varPtr[varIndex],
340 &boolValue) != TCL_OK) {
341 return TCL_ERROR;
342 }
343 if (!Tcl_IsShared(varPtr[varIndex])) {
344 Tcl_SetBooleanObj(varPtr[varIndex], !boolValue);
345 } else {
346 SetVarToObj(varIndex, Tcl_NewBooleanObj(!boolValue));
347 }
348 Tcl_SetObjResult(interp, varPtr[varIndex]);
349 } else {
350 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
351 "bad option \"", Tcl_GetString(objv[1]),
352 "\": must be set, get, or not", NULL);
353 return TCL_ERROR;
354 }
355 return TCL_OK;
356 }
357
358 /*
359 *----------------------------------------------------------------------
360 *
361 * TestdoubleobjCmd --
362 *
363 * This function implements the "testdoubleobj" command. It is used to
364 * test the double-precision floating point Tcl object type
365 * implementation.
366 *
367 * Results:
368 * A standard Tcl object result.
369 *
370 * Side effects:
371 * Creates and frees double objects, and also converts objects to
372 * have double type.
373 *
374 *----------------------------------------------------------------------
375 */
376
377 static int
TestdoubleobjCmd(ClientData clientData,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])378 TestdoubleobjCmd(
379 ClientData clientData, /* Not used. */
380 Tcl_Interp *interp, /* Current interpreter. */
381 int objc, /* Number of arguments. */
382 Tcl_Obj *const objv[]) /* Argument objects. */
383 {
384 int varIndex;
385 double doubleValue;
386 char *index, *subCmd, *string;
387
388 if (objc < 3) {
389 wrongNumArgs:
390 Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");
391 return TCL_ERROR;
392 }
393
394 index = Tcl_GetString(objv[2]);
395 if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
396 return TCL_ERROR;
397 }
398
399 subCmd = Tcl_GetString(objv[1]);
400 if (strcmp(subCmd, "set") == 0) {
401 if (objc != 4) {
402 goto wrongNumArgs;
403 }
404 string = Tcl_GetString(objv[3]);
405 if (Tcl_GetDouble(interp, string, &doubleValue) != TCL_OK) {
406 return TCL_ERROR;
407 }
408
409 /*
410 * If the object currently bound to the variable with index varIndex
411 * has ref count 1 (i.e. the object is unshared) we can modify that
412 * object directly. Otherwise, if RC>1 (i.e. the object is shared), we
413 * must create a new object to modify/set and decrement the old
414 * formerly-shared object's ref count. This is "copy on write".
415 */
416
417 if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
418 Tcl_SetDoubleObj(varPtr[varIndex], doubleValue);
419 } else {
420 SetVarToObj(varIndex, Tcl_NewDoubleObj(doubleValue));
421 }
422 Tcl_SetObjResult(interp, varPtr[varIndex]);
423 } else if (strcmp(subCmd, "get") == 0) {
424 if (objc != 3) {
425 goto wrongNumArgs;
426 }
427 if (CheckIfVarUnset(interp, varIndex)) {
428 return TCL_ERROR;
429 }
430 Tcl_SetObjResult(interp, varPtr[varIndex]);
431 } else if (strcmp(subCmd, "mult10") == 0) {
432 if (objc != 3) {
433 goto wrongNumArgs;
434 }
435 if (CheckIfVarUnset(interp, varIndex)) {
436 return TCL_ERROR;
437 }
438 if (Tcl_GetDoubleFromObj(interp, varPtr[varIndex],
439 &doubleValue) != TCL_OK) {
440 return TCL_ERROR;
441 }
442 if (!Tcl_IsShared(varPtr[varIndex])) {
443 Tcl_SetDoubleObj(varPtr[varIndex], (doubleValue * 10.0));
444 } else {
445 SetVarToObj(varIndex, Tcl_NewDoubleObj( (doubleValue * 10.0) ));
446 }
447 Tcl_SetObjResult(interp, varPtr[varIndex]);
448 } else if (strcmp(subCmd, "div10") == 0) {
449 if (objc != 3) {
450 goto wrongNumArgs;
451 }
452 if (CheckIfVarUnset(interp, varIndex)) {
453 return TCL_ERROR;
454 }
455 if (Tcl_GetDoubleFromObj(interp, varPtr[varIndex],
456 &doubleValue) != TCL_OK) {
457 return TCL_ERROR;
458 }
459 if (!Tcl_IsShared(varPtr[varIndex])) {
460 Tcl_SetDoubleObj(varPtr[varIndex], (doubleValue / 10.0));
461 } else {
462 SetVarToObj(varIndex, Tcl_NewDoubleObj( (doubleValue / 10.0) ));
463 }
464 Tcl_SetObjResult(interp, varPtr[varIndex]);
465 } else {
466 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
467 "bad option \"", Tcl_GetString(objv[1]),
468 "\": must be set, get, mult10, or div10", NULL);
469 return TCL_ERROR;
470 }
471 return TCL_OK;
472 }
473
474 /*
475 *----------------------------------------------------------------------
476 *
477 * TestindexobjCmd --
478 *
479 * This function implements the "testindexobj" command. It is used to
480 * test the index Tcl object type implementation.
481 *
482 * Results:
483 * A standard Tcl object result.
484 *
485 * Side effects:
486 * Creates and frees int objects, and also converts objects to
487 * have int type.
488 *
489 *----------------------------------------------------------------------
490 */
491
492 static int
TestindexobjCmd(ClientData clientData,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])493 TestindexobjCmd(
494 ClientData clientData, /* Not used. */
495 Tcl_Interp *interp, /* Current interpreter. */
496 int objc, /* Number of arguments. */
497 Tcl_Obj *const objv[]) /* Argument objects. */
498 {
499 int allowAbbrev, index, index2, setError, i, result;
500 const char **argv;
501 static const char *tablePtr[] = {"a", "b", "check", NULL};
502 /*
503 * Keep this structure declaration in sync with tclIndexObj.c
504 */
505 struct IndexRep {
506 VOID *tablePtr; /* Pointer to the table of strings */
507 int offset; /* Offset between table entries */
508 int index; /* Selected index into table. */
509 };
510 struct IndexRep *indexRep;
511
512 if ((objc == 3) && (strcmp(Tcl_GetString(objv[1]),
513 "check") == 0)) {
514 /*
515 * This code checks to be sure that the results of Tcl_GetIndexFromObj
516 * are properly cached in the object and returned on subsequent
517 * lookups.
518 */
519
520 if (Tcl_GetIntFromObj(interp, objv[2], &index2) != TCL_OK) {
521 return TCL_ERROR;
522 }
523
524 Tcl_GetIndexFromObj(NULL, objv[1], tablePtr, "token", 0, &index);
525 indexRep = (struct IndexRep *) objv[1]->internalRep.twoPtrValue.ptr1;
526 indexRep->index = index2;
527 result = Tcl_GetIndexFromObj(NULL, objv[1],
528 tablePtr, "token", 0, &index);
529 if (result == TCL_OK) {
530 Tcl_SetIntObj(Tcl_GetObjResult(interp), index);
531 }
532 return result;
533 }
534
535 if (objc < 5) {
536 Tcl_AppendToObj(Tcl_GetObjResult(interp), "wrong # args", -1);
537 return TCL_ERROR;
538 }
539
540 if (Tcl_GetBooleanFromObj(interp, objv[1], &setError) != TCL_OK) {
541 return TCL_ERROR;
542 }
543 if (Tcl_GetBooleanFromObj(interp, objv[2], &allowAbbrev) != TCL_OK) {
544 return TCL_ERROR;
545 }
546
547 argv = (const char **) ckalloc((unsigned) ((objc-3) * sizeof(char *)));
548 for (i = 4; i < objc; i++) {
549 argv[i-4] = Tcl_GetString(objv[i]);
550 }
551 argv[objc-4] = NULL;
552
553 /*
554 * Tcl_GetIndexFromObj assumes that the table is statically-allocated so
555 * that its address is different for each index object. If we accidently
556 * allocate a table at the same address as that cached in the index
557 * object, clear out the object's cached state.
558 */
559
560 if ( objv[3]->typePtr != NULL
561 && !strcmp( "index", objv[3]->typePtr->name ) ) {
562 indexRep = (struct IndexRep *) objv[3]->internalRep.twoPtrValue.ptr1;
563 if (indexRep->tablePtr == (VOID *) argv) {
564 objv[3]->typePtr->freeIntRepProc(objv[3]);
565 objv[3]->typePtr = NULL;
566 }
567 }
568
569 result = Tcl_GetIndexFromObj((setError? interp : NULL), objv[3],
570 argv, "token", (allowAbbrev? 0 : TCL_EXACT), &index);
571 ckfree((char *) argv);
572 if (result == TCL_OK) {
573 Tcl_SetIntObj(Tcl_GetObjResult(interp), index);
574 }
575 return result;
576 }
577
578 /*
579 *----------------------------------------------------------------------
580 *
581 * TestintobjCmd --
582 *
583 * This function implements the "testintobj" command. It is used to
584 * test the int Tcl object type implementation.
585 *
586 * Results:
587 * A standard Tcl object result.
588 *
589 * Side effects:
590 * Creates and frees int objects, and also converts objects to
591 * have int type.
592 *
593 *----------------------------------------------------------------------
594 */
595
596 static int
TestintobjCmd(ClientData clientData,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])597 TestintobjCmd(
598 ClientData clientData, /* Not used. */
599 Tcl_Interp *interp, /* Current interpreter. */
600 int objc, /* Number of arguments. */
601 Tcl_Obj *const objv[]) /* Argument objects. */
602 {
603 int intValue, varIndex, i;
604 long longValue;
605 char *index, *subCmd, *string;
606
607 if (objc < 3) {
608 wrongNumArgs:
609 Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");
610 return TCL_ERROR;
611 }
612
613 index = Tcl_GetString(objv[2]);
614 if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
615 return TCL_ERROR;
616 }
617
618 subCmd = Tcl_GetString(objv[1]);
619 if (strcmp(subCmd, "set") == 0) {
620 if (objc != 4) {
621 goto wrongNumArgs;
622 }
623 string = Tcl_GetString(objv[3]);
624 if (Tcl_GetInt(interp, string, &i) != TCL_OK) {
625 return TCL_ERROR;
626 }
627 intValue = i;
628
629 /*
630 * If the object currently bound to the variable with index varIndex
631 * has ref count 1 (i.e. the object is unshared) we can modify that
632 * object directly. Otherwise, if RC>1 (i.e. the object is shared), we
633 * must create a new object to modify/set and decrement the old
634 * formerly-shared object's ref count. This is "copy on write".
635 */
636
637 if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
638 Tcl_SetIntObj(varPtr[varIndex], intValue);
639 } else {
640 SetVarToObj(varIndex, Tcl_NewIntObj(intValue));
641 }
642 Tcl_SetObjResult(interp, varPtr[varIndex]);
643 } else if (strcmp(subCmd, "set2") == 0) { /* doesn't set result */
644 if (objc != 4) {
645 goto wrongNumArgs;
646 }
647 string = Tcl_GetString(objv[3]);
648 if (Tcl_GetInt(interp, string, &i) != TCL_OK) {
649 return TCL_ERROR;
650 }
651 intValue = i;
652 if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
653 Tcl_SetIntObj(varPtr[varIndex], intValue);
654 } else {
655 SetVarToObj(varIndex, Tcl_NewIntObj(intValue));
656 }
657 } else if (strcmp(subCmd, "setlong") == 0) {
658 if (objc != 4) {
659 goto wrongNumArgs;
660 }
661 string = Tcl_GetString(objv[3]);
662 if (Tcl_GetInt(interp, string, &i) != TCL_OK) {
663 return TCL_ERROR;
664 }
665 intValue = i;
666 if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
667 Tcl_SetLongObj(varPtr[varIndex], intValue);
668 } else {
669 SetVarToObj(varIndex, Tcl_NewLongObj(intValue));
670 }
671 Tcl_SetObjResult(interp, varPtr[varIndex]);
672 } else if (strcmp(subCmd, "setmaxlong") == 0) {
673 long maxLong = LONG_MAX;
674 if (objc != 3) {
675 goto wrongNumArgs;
676 }
677 if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
678 Tcl_SetLongObj(varPtr[varIndex], maxLong);
679 } else {
680 SetVarToObj(varIndex, Tcl_NewLongObj(maxLong));
681 }
682 } else if (strcmp(subCmd, "ismaxlong") == 0) {
683 if (objc != 3) {
684 goto wrongNumArgs;
685 }
686 if (CheckIfVarUnset(interp, varIndex)) {
687 return TCL_ERROR;
688 }
689 if (Tcl_GetLongFromObj(interp, varPtr[varIndex], &longValue) != TCL_OK) {
690 return TCL_ERROR;
691 }
692 Tcl_AppendToObj(Tcl_GetObjResult(interp),
693 ((longValue == LONG_MAX)? "1" : "0"), -1);
694 } else if (strcmp(subCmd, "get") == 0) {
695 if (objc != 3) {
696 goto wrongNumArgs;
697 }
698 if (CheckIfVarUnset(interp, varIndex)) {
699 return TCL_ERROR;
700 }
701 Tcl_SetObjResult(interp, varPtr[varIndex]);
702 } else if (strcmp(subCmd, "get2") == 0) {
703 if (objc != 3) {
704 goto wrongNumArgs;
705 }
706 if (CheckIfVarUnset(interp, varIndex)) {
707 return TCL_ERROR;
708 }
709 string = Tcl_GetString(varPtr[varIndex]);
710 Tcl_AppendToObj(Tcl_GetObjResult(interp), string, -1);
711 } else if (strcmp(subCmd, "inttoobigtest") == 0) {
712 /*
713 * If long ints have more bits than ints on this platform, verify that
714 * Tcl_GetIntFromObj returns an error if the long int held in an
715 * integer object's internal representation is too large to fit in an
716 * int.
717 */
718
719 if (objc != 3) {
720 goto wrongNumArgs;
721 }
722 #if (INT_MAX == LONG_MAX) /* int is same size as long int */
723 Tcl_AppendToObj(Tcl_GetObjResult(interp), "1", -1);
724 #else
725 if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
726 Tcl_SetLongObj(varPtr[varIndex], LONG_MAX);
727 } else {
728 SetVarToObj(varIndex, Tcl_NewLongObj(LONG_MAX));
729 }
730 if (Tcl_GetIntFromObj(interp, varPtr[varIndex], &i) != TCL_OK) {
731 Tcl_ResetResult(interp);
732 Tcl_AppendToObj(Tcl_GetObjResult(interp), "1", -1);
733 return TCL_OK;
734 }
735 Tcl_AppendToObj(Tcl_GetObjResult(interp), "0", -1);
736 #endif
737 } else if (strcmp(subCmd, "mult10") == 0) {
738 if (objc != 3) {
739 goto wrongNumArgs;
740 }
741 if (CheckIfVarUnset(interp, varIndex)) {
742 return TCL_ERROR;
743 }
744 if (Tcl_GetIntFromObj(interp, varPtr[varIndex],
745 &intValue) != TCL_OK) {
746 return TCL_ERROR;
747 }
748 if (!Tcl_IsShared(varPtr[varIndex])) {
749 Tcl_SetIntObj(varPtr[varIndex], (intValue * 10));
750 } else {
751 SetVarToObj(varIndex, Tcl_NewIntObj( (intValue * 10) ));
752 }
753 Tcl_SetObjResult(interp, varPtr[varIndex]);
754 } else if (strcmp(subCmd, "div10") == 0) {
755 if (objc != 3) {
756 goto wrongNumArgs;
757 }
758 if (CheckIfVarUnset(interp, varIndex)) {
759 return TCL_ERROR;
760 }
761 if (Tcl_GetIntFromObj(interp, varPtr[varIndex],
762 &intValue) != TCL_OK) {
763 return TCL_ERROR;
764 }
765 if (!Tcl_IsShared(varPtr[varIndex])) {
766 Tcl_SetIntObj(varPtr[varIndex], (intValue / 10));
767 } else {
768 SetVarToObj(varIndex, Tcl_NewIntObj( (intValue / 10) ));
769 }
770 Tcl_SetObjResult(interp, varPtr[varIndex]);
771 } else {
772 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
773 "bad option \"", Tcl_GetString(objv[1]),
774 "\": must be set, get, get2, mult10, or div10", NULL);
775 return TCL_ERROR;
776 }
777 return TCL_OK;
778 }
779
780 /*
781 *-----------------------------------------------------------------------------
782 *
783 * TestlistobjCmd --
784 *
785 * This function implements the 'testlistobj' command. It is used to
786 * test a few possible corner cases in list object manipulation from
787 * C code that cannot occur at the Tcl level.
788 *
789 * Results:
790 * A standard Tcl object result.
791 *
792 * Side effects:
793 * Creates, manipulates and frees list objects.
794 *
795 *-----------------------------------------------------------------------------
796 */
797
798 static int
TestlistobjCmd(ClientData clientData,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])799 TestlistobjCmd(
800 ClientData clientData, /* Not used */
801 Tcl_Interp *interp, /* Tcl interpreter */
802 int objc, /* Number of arguments */
803 Tcl_Obj *const objv[]) /* Argument objects */
804 {
805 /* Subcommands supported by this command */
806 const char* subcommands[] = {
807 "set",
808 "get",
809 "replace"
810 };
811 enum listobjCmdIndex {
812 LISTOBJ_SET,
813 LISTOBJ_GET,
814 LISTOBJ_REPLACE
815 };
816
817 const char* index; /* Argument giving the variable number */
818 int varIndex; /* Variable number converted to binary */
819 int cmdIndex; /* Ordinal number of the subcommand */
820 int first; /* First index in the list */
821 int count; /* Count of elements in a list */
822
823 if (objc < 3) {
824 Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg...?");
825 return TCL_ERROR;
826 }
827 index = Tcl_GetString(objv[2]);
828 if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
829 return TCL_ERROR;
830 }
831 if (Tcl_GetIndexFromObj(interp, objv[1], subcommands, "command",
832 0, &cmdIndex) != TCL_OK) {
833 return TCL_ERROR;
834 }
835 switch(cmdIndex) {
836 case LISTOBJ_SET:
837 if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
838 Tcl_SetListObj(varPtr[varIndex], objc-3, objv+3);
839 } else {
840 SetVarToObj(varIndex, Tcl_NewListObj(objc-3, objv+3));
841 }
842 Tcl_SetObjResult(interp, varPtr[varIndex]);
843 break;
844
845 case LISTOBJ_GET:
846 if (objc != 3) {
847 Tcl_WrongNumArgs(interp, 2, objv, "varIndex");
848 return TCL_ERROR;
849 }
850 if (CheckIfVarUnset(interp, varIndex)) {
851 return TCL_ERROR;
852 }
853 Tcl_SetObjResult(interp, varPtr[varIndex]);
854 break;
855
856 case LISTOBJ_REPLACE:
857 if (objc < 5) {
858 Tcl_WrongNumArgs(interp, 2, objv,
859 "varIndex start count ?element...?");
860 return TCL_ERROR;
861 }
862 if (Tcl_GetIntFromObj(interp, objv[3], &first) != TCL_OK
863 || Tcl_GetIntFromObj(interp, objv[4], &count) != TCL_OK) {
864 return TCL_ERROR;
865 }
866 if (Tcl_IsShared(varPtr[varIndex])) {
867 SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex]));
868 }
869 Tcl_ResetResult(interp);
870 return Tcl_ListObjReplace(interp, varPtr[varIndex], first, count,
871 objc-5, objv+5);
872 }
873 return TCL_OK;
874 }
875
876 /*
877 *----------------------------------------------------------------------
878 *
879 * TestobjCmd --
880 *
881 * This function implements the "testobj" command. It is used to test
882 * the type-independent portions of the Tcl object type implementation.
883 *
884 * Results:
885 * A standard Tcl object result.
886 *
887 * Side effects:
888 * Creates and frees objects.
889 *
890 *----------------------------------------------------------------------
891 */
892
893 static int
TestobjCmd(ClientData clientData,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])894 TestobjCmd(
895 ClientData clientData, /* Not used. */
896 Tcl_Interp *interp, /* Current interpreter. */
897 int objc, /* Number of arguments. */
898 Tcl_Obj *const objv[]) /* Argument objects. */
899 {
900 int varIndex, destIndex, i;
901 char *index, *subCmd, *string;
902 Tcl_ObjType *targetType;
903
904 if (objc < 2) {
905 wrongNumArgs:
906 Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");
907 return TCL_ERROR;
908 }
909
910 subCmd = Tcl_GetString(objv[1]);
911 if (strcmp(subCmd, "assign") == 0) {
912 if (objc != 4) {
913 goto wrongNumArgs;
914 }
915 index = Tcl_GetString(objv[2]);
916 if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
917 return TCL_ERROR;
918 }
919 if (CheckIfVarUnset(interp, varIndex)) {
920 return TCL_ERROR;
921 }
922 string = Tcl_GetString(objv[3]);
923 if (GetVariableIndex(interp, string, &destIndex) != TCL_OK) {
924 return TCL_ERROR;
925 }
926 SetVarToObj(destIndex, varPtr[varIndex]);
927 Tcl_SetObjResult(interp, varPtr[destIndex]);
928 } else if (strcmp(subCmd, "bug3598580") == 0) {
929 Tcl_Obj *listObjPtr, *elemObjPtr;
930 if (objc != 2) {
931 goto wrongNumArgs;
932 }
933 elemObjPtr = Tcl_NewIntObj(123);
934 listObjPtr = Tcl_NewListObj(1, &elemObjPtr);
935 /* Replace the single list element through itself, nonsense but legal. */
936 Tcl_ListObjReplace(interp, listObjPtr, 0, 1, 1, &elemObjPtr);
937 Tcl_SetObjResult(interp, listObjPtr);
938 return TCL_OK;
939 } else if (strcmp(subCmd, "convert") == 0) {
940 char *typeName;
941 if (objc != 4) {
942 goto wrongNumArgs;
943 }
944 index = Tcl_GetString(objv[2]);
945 if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
946 return TCL_ERROR;
947 }
948 if (CheckIfVarUnset(interp, varIndex)) {
949 return TCL_ERROR;
950 }
951 typeName = Tcl_GetString(objv[3]);
952 if ((targetType = Tcl_GetObjType(typeName)) == NULL) {
953 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
954 "no type ", typeName, " found", NULL);
955 return TCL_ERROR;
956 }
957 if (Tcl_ConvertToType(interp, varPtr[varIndex], targetType)
958 != TCL_OK) {
959 return TCL_ERROR;
960 }
961 Tcl_SetObjResult(interp, varPtr[varIndex]);
962 } else if (strcmp(subCmd, "duplicate") == 0) {
963 if (objc != 4) {
964 goto wrongNumArgs;
965 }
966 index = Tcl_GetString(objv[2]);
967 if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
968 return TCL_ERROR;
969 }
970 if (CheckIfVarUnset(interp, varIndex)) {
971 return TCL_ERROR;
972 }
973 string = Tcl_GetString(objv[3]);
974 if (GetVariableIndex(interp, string, &destIndex) != TCL_OK) {
975 return TCL_ERROR;
976 }
977 SetVarToObj(destIndex, Tcl_DuplicateObj(varPtr[varIndex]));
978 Tcl_SetObjResult(interp, varPtr[destIndex]);
979 } else if (strcmp(subCmd, "freeallvars") == 0) {
980 if (objc != 2) {
981 goto wrongNumArgs;
982 }
983 for (i = 0; i < NUMBER_OF_OBJECT_VARS; i++) {
984 if (varPtr[i] != NULL) {
985 Tcl_DecrRefCount(varPtr[i]);
986 varPtr[i] = NULL;
987 }
988 }
989 } else if ( strcmp ( subCmd, "invalidateStringRep" ) == 0 ) {
990 if ( objc != 3 ) {
991 goto wrongNumArgs;
992 }
993 index = Tcl_GetString( objv[2] );
994 if ( GetVariableIndex( interp, index, &varIndex ) != TCL_OK ) {
995 return TCL_ERROR;
996 }
997 if (CheckIfVarUnset(interp, varIndex)) {
998 return TCL_ERROR;
999 }
1000 Tcl_InvalidateStringRep( varPtr[varIndex] );
1001 Tcl_SetObjResult( interp, varPtr[varIndex] );
1002 } else if (strcmp(subCmd, "newobj") == 0) {
1003 if (objc != 3) {
1004 goto wrongNumArgs;
1005 }
1006 index = Tcl_GetString(objv[2]);
1007 if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
1008 return TCL_ERROR;
1009 }
1010 SetVarToObj(varIndex, Tcl_NewObj());
1011 Tcl_SetObjResult(interp, varPtr[varIndex]);
1012 } else if (strcmp(subCmd, "objtype") == 0) {
1013 const char *typeName;
1014
1015 /*
1016 * return an object containing the name of the argument's type
1017 * of internal rep. If none exists, return "none".
1018 */
1019
1020 if (objc != 3) {
1021 goto wrongNumArgs;
1022 }
1023 if (objv[2]->typePtr == NULL) {
1024 Tcl_SetObjResult(interp, Tcl_NewStringObj("none", -1));
1025 } else {
1026 typeName = objv[2]->typePtr->name;
1027 Tcl_SetObjResult(interp, Tcl_NewStringObj(typeName, -1));
1028 }
1029 } else if (strcmp(subCmd, "refcount") == 0) {
1030 char buf[TCL_INTEGER_SPACE];
1031
1032 if (objc != 3) {
1033 goto wrongNumArgs;
1034 }
1035 index = Tcl_GetString(objv[2]);
1036 if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
1037 return TCL_ERROR;
1038 }
1039 if (CheckIfVarUnset(interp, varIndex)) {
1040 return TCL_ERROR;
1041 }
1042 TclFormatInt(buf, varPtr[varIndex]->refCount);
1043 Tcl_SetResult(interp, buf, TCL_VOLATILE);
1044 } else if (strcmp(subCmd, "type") == 0) {
1045 if (objc != 3) {
1046 goto wrongNumArgs;
1047 }
1048 index = Tcl_GetString(objv[2]);
1049 if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
1050 return TCL_ERROR;
1051 }
1052 if (CheckIfVarUnset(interp, varIndex)) {
1053 return TCL_ERROR;
1054 }
1055 if (varPtr[varIndex]->typePtr == NULL) { /* a string! */
1056 Tcl_AppendToObj(Tcl_GetObjResult(interp), "string", -1);
1057 } else {
1058 Tcl_AppendToObj(Tcl_GetObjResult(interp),
1059 varPtr[varIndex]->typePtr->name, -1);
1060 }
1061 } else if (strcmp(subCmd, "types") == 0) {
1062 if (objc != 2) {
1063 goto wrongNumArgs;
1064 }
1065 if (Tcl_AppendAllObjTypes(interp,
1066 Tcl_GetObjResult(interp)) != TCL_OK) {
1067 return TCL_ERROR;
1068 }
1069 } else {
1070 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1071 "bad option \"", Tcl_GetString(objv[1]),
1072 "\": must be assign, convert, duplicate, freeallvars, "
1073 "newobj, objcount, objtype, refcount, type, or types", NULL);
1074 return TCL_ERROR;
1075 }
1076 return TCL_OK;
1077 }
1078
1079 /*
1080 *----------------------------------------------------------------------
1081 *
1082 * TeststringobjCmd --
1083 *
1084 * This function implements the "teststringobj" command. It is used to
1085 * test the string Tcl object type implementation.
1086 *
1087 * Results:
1088 * A standard Tcl object result.
1089 *
1090 * Side effects:
1091 * Creates and frees string objects, and also converts objects to
1092 * have string type.
1093 *
1094 *----------------------------------------------------------------------
1095 */
1096
1097 static int
TeststringobjCmd(ClientData clientData,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])1098 TeststringobjCmd(
1099 ClientData clientData, /* Not used. */
1100 Tcl_Interp *interp, /* Current interpreter. */
1101 int objc, /* Number of arguments. */
1102 Tcl_Obj *const objv[]) /* Argument objects. */
1103 {
1104 int varIndex, option, i, length;
1105 Tcl_UniChar *unicode;
1106 #define MAX_STRINGS 11
1107 char *index, *string, *strings[MAX_STRINGS+1];
1108 TestString *strPtr;
1109 static const char *options[] = {
1110 "append", "appendstrings", "get", "get2", "length", "length2",
1111 "set", "set2", "setlength", "ualloc", "getunicode",
1112 "appendself", "appendself2", NULL
1113 };
1114
1115 if (objc < 3) {
1116 wrongNumArgs:
1117 Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");
1118 return TCL_ERROR;
1119 }
1120
1121 index = Tcl_GetString(objv[2]);
1122 if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
1123 return TCL_ERROR;
1124 }
1125
1126 if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, &option)
1127 != TCL_OK) {
1128 return TCL_ERROR;
1129 }
1130 switch (option) {
1131 case 0: /* append */
1132 if (objc != 5) {
1133 goto wrongNumArgs;
1134 }
1135 if (Tcl_GetIntFromObj(interp, objv[4], &length) != TCL_OK) {
1136 return TCL_ERROR;
1137 }
1138 if (varPtr[varIndex] == NULL) {
1139 SetVarToObj(varIndex, Tcl_NewObj());
1140 }
1141
1142 /*
1143 * If the object bound to variable "varIndex" is shared, we must
1144 * "copy on write" and append to a copy of the object.
1145 */
1146
1147 if (Tcl_IsShared(varPtr[varIndex])) {
1148 SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex]));
1149 }
1150 string = Tcl_GetString(objv[3]);
1151 Tcl_AppendToObj(varPtr[varIndex], string, length);
1152 Tcl_SetObjResult(interp, varPtr[varIndex]);
1153 break;
1154 case 1: /* appendstrings */
1155 if (objc > (MAX_STRINGS+3)) {
1156 goto wrongNumArgs;
1157 }
1158 if (varPtr[varIndex] == NULL) {
1159 SetVarToObj(varIndex, Tcl_NewObj());
1160 }
1161
1162 /*
1163 * If the object bound to variable "varIndex" is shared, we must
1164 * "copy on write" and append to a copy of the object.
1165 */
1166
1167 if (Tcl_IsShared(varPtr[varIndex])) {
1168 SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex]));
1169 }
1170 for (i = 3; i < objc; i++) {
1171 strings[i-3] = Tcl_GetString(objv[i]);
1172 }
1173 for ( ; i < 12 + 3; i++) {
1174 strings[i - 3] = NULL;
1175 }
1176 Tcl_AppendStringsToObj(varPtr[varIndex], strings[0], strings[1],
1177 strings[2], strings[3], strings[4], strings[5],
1178 strings[6], strings[7], strings[8], strings[9],
1179 strings[10], strings[11]);
1180 Tcl_SetObjResult(interp, varPtr[varIndex]);
1181 break;
1182 case 2: /* get */
1183 if (objc != 3) {
1184 goto wrongNumArgs;
1185 }
1186 if (CheckIfVarUnset(interp, varIndex)) {
1187 return TCL_ERROR;
1188 }
1189 Tcl_SetObjResult(interp, varPtr[varIndex]);
1190 break;
1191 case 3: /* get2 */
1192 if (objc != 3) {
1193 goto wrongNumArgs;
1194 }
1195 if (CheckIfVarUnset(interp, varIndex)) {
1196 return TCL_ERROR;
1197 }
1198 string = Tcl_GetString(varPtr[varIndex]);
1199 Tcl_AppendToObj(Tcl_GetObjResult(interp), string, -1);
1200 break;
1201 case 4: /* length */
1202 if (objc != 3) {
1203 goto wrongNumArgs;
1204 }
1205 Tcl_SetIntObj(Tcl_GetObjResult(interp), (varPtr[varIndex] != NULL)
1206 ? varPtr[varIndex]->length : -1);
1207 break;
1208 case 5: /* length2 */
1209 if (objc != 3) {
1210 goto wrongNumArgs;
1211 }
1212 if (varPtr[varIndex] != NULL) {
1213 strPtr = (TestString *)
1214 (varPtr[varIndex])->internalRep.twoPtrValue.ptr1;
1215 length = (int) strPtr->allocated;
1216 } else {
1217 length = -1;
1218 }
1219 Tcl_SetIntObj(Tcl_GetObjResult(interp), length);
1220 break;
1221 case 6: /* set */
1222 if (objc != 4) {
1223 goto wrongNumArgs;
1224 }
1225
1226 /*
1227 * If the object currently bound to the variable with index
1228 * varIndex has ref count 1 (i.e. the object is unshared) we can
1229 * modify that object directly. Otherwise, if RC>1 (i.e. the
1230 * object is shared), we must create a new object to modify/set
1231 * and decrement the old formerly-shared object's ref count. This
1232 * is "copy on write".
1233 */
1234
1235 string = Tcl_GetStringFromObj(objv[3], &length);
1236 if ((varPtr[varIndex] != NULL)
1237 && !Tcl_IsShared(varPtr[varIndex])) {
1238 Tcl_SetStringObj(varPtr[varIndex], string, length);
1239 } else {
1240 SetVarToObj(varIndex, Tcl_NewStringObj(string, length));
1241 }
1242 Tcl_SetObjResult(interp, varPtr[varIndex]);
1243 break;
1244 case 7: /* set2 */
1245 if (objc != 4) {
1246 goto wrongNumArgs;
1247 }
1248 SetVarToObj(varIndex, objv[3]);
1249 break;
1250 case 8: /* setlength */
1251 if (objc != 4) {
1252 goto wrongNumArgs;
1253 }
1254 if (Tcl_GetIntFromObj(interp, objv[3], &length) != TCL_OK) {
1255 return TCL_ERROR;
1256 }
1257 if (varPtr[varIndex] != NULL) {
1258 Tcl_SetObjLength(varPtr[varIndex], length);
1259 }
1260 break;
1261 case 9: /* ualloc */
1262 if (objc != 3) {
1263 goto wrongNumArgs;
1264 }
1265 if (varPtr[varIndex] != NULL) {
1266 strPtr = (TestString *)
1267 (varPtr[varIndex])->internalRep.twoPtrValue.ptr1;
1268 length = (int) strPtr->uallocated;
1269 } else {
1270 length = -1;
1271 }
1272 Tcl_SetIntObj(Tcl_GetObjResult(interp), length);
1273 break;
1274 case 10: /* getunicode */
1275 if (objc != 3) {
1276 goto wrongNumArgs;
1277 }
1278 Tcl_GetUnicodeFromObj(varPtr[varIndex], NULL);
1279 break;
1280 case 11: /* appendself */
1281 if (objc != 4) {
1282 goto wrongNumArgs;
1283 }
1284 if (varPtr[varIndex] == NULL) {
1285 SetVarToObj(varIndex, Tcl_NewObj());
1286 }
1287
1288 /*
1289 * If the object bound to variable "varIndex" is shared, we must
1290 * "copy on write" and append to a copy of the object.
1291 */
1292
1293 if (Tcl_IsShared(varPtr[varIndex])) {
1294 SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex]));
1295 }
1296
1297 string = Tcl_GetStringFromObj(varPtr[varIndex], &length);
1298
1299 if (Tcl_GetIntFromObj(interp, objv[3], &i) != TCL_OK) {
1300 return TCL_ERROR;
1301 }
1302 if ((i < 0) || (i > length)) {
1303 Tcl_SetObjResult(interp, Tcl_NewStringObj(
1304 "index value out of range", -1));
1305 return TCL_ERROR;
1306 }
1307
1308 Tcl_AppendToObj(varPtr[varIndex], string + i, length - i);
1309 Tcl_SetObjResult(interp, varPtr[varIndex]);
1310 break;
1311 case 12: /* appendself2 */
1312 if (objc != 4) {
1313 goto wrongNumArgs;
1314 }
1315 if (varPtr[varIndex] == NULL) {
1316 SetVarToObj(varIndex, Tcl_NewObj());
1317 }
1318
1319 /*
1320 * If the object bound to variable "varIndex" is shared, we must
1321 * "copy on write" and append to a copy of the object.
1322 */
1323
1324 if (Tcl_IsShared(varPtr[varIndex])) {
1325 SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex]));
1326 }
1327
1328 unicode = Tcl_GetUnicodeFromObj(varPtr[varIndex], &length);
1329
1330 if (Tcl_GetIntFromObj(interp, objv[3], &i) != TCL_OK) {
1331 return TCL_ERROR;
1332 }
1333 if ((i < 0) || (i > length)) {
1334 Tcl_SetObjResult(interp, Tcl_NewStringObj(
1335 "index value out of range", -1));
1336 return TCL_ERROR;
1337 }
1338
1339 Tcl_AppendUnicodeToObj(varPtr[varIndex], unicode + i, length - i);
1340 Tcl_SetObjResult(interp, varPtr[varIndex]);
1341 break;
1342 }
1343
1344 return TCL_OK;
1345 }
1346
1347 /*
1348 *----------------------------------------------------------------------
1349 *
1350 * SetVarToObj --
1351 *
1352 * Utility routine to assign a Tcl_Obj* to a test variable. The
1353 * Tcl_Obj* can be NULL.
1354 *
1355 * Results:
1356 * None.
1357 *
1358 * Side effects:
1359 * This routine handles ref counting details for assignment: i.e. the old
1360 * value's ref count must be decremented (if not NULL) and the new one
1361 * incremented (also if not NULL).
1362 *
1363 *----------------------------------------------------------------------
1364 */
1365
1366 static void
SetVarToObj(int varIndex,Tcl_Obj * objPtr)1367 SetVarToObj(
1368 int varIndex, /* Designates the assignment variable. */
1369 Tcl_Obj *objPtr) /* Points to object to assign to var. */
1370 {
1371 if (varPtr[varIndex] != NULL) {
1372 Tcl_DecrRefCount(varPtr[varIndex]);
1373 }
1374 varPtr[varIndex] = objPtr;
1375 if (objPtr != NULL) {
1376 Tcl_IncrRefCount(objPtr);
1377 }
1378 }
1379
1380 /*
1381 *----------------------------------------------------------------------
1382 *
1383 * GetVariableIndex --
1384 *
1385 * Utility routine to get a test variable index from the command line.
1386 *
1387 * Results:
1388 * A standard Tcl object result.
1389 *
1390 * Side effects:
1391 * None.
1392 *
1393 *----------------------------------------------------------------------
1394 */
1395
1396 static int
GetVariableIndex(Tcl_Interp * interp,const char * string,int * indexPtr)1397 GetVariableIndex(
1398 Tcl_Interp *interp, /* Interpreter for error reporting. */
1399 const char *string, /* String containing a variable index
1400 * specified as a nonnegative number less than
1401 * NUMBER_OF_OBJECT_VARS. */
1402 int *indexPtr) /* Place to store converted result. */
1403 {
1404 int index;
1405
1406 if (Tcl_GetInt(interp, string, &index) != TCL_OK) {
1407 return TCL_ERROR;
1408 }
1409 if (index < 0 || index >= NUMBER_OF_OBJECT_VARS) {
1410 Tcl_ResetResult(interp);
1411 Tcl_AppendToObj(Tcl_GetObjResult(interp), "bad variable index", -1);
1412 return TCL_ERROR;
1413 }
1414
1415 *indexPtr = index;
1416 return TCL_OK;
1417 }
1418
1419 /*
1420 *----------------------------------------------------------------------
1421 *
1422 * CheckIfVarUnset --
1423 *
1424 * Utility function that checks whether a test variable is readable:
1425 * i.e., that varPtr[varIndex] is non-NULL.
1426 *
1427 * Results:
1428 * 1 if the test variable is unset (NULL); 0 otherwise.
1429 *
1430 * Side effects:
1431 * Sets the interpreter result to an error message if the variable is
1432 * unset (NULL).
1433 *
1434 *----------------------------------------------------------------------
1435 */
1436
1437 static int
CheckIfVarUnset(Tcl_Interp * interp,int varIndex)1438 CheckIfVarUnset(
1439 Tcl_Interp *interp, /* Interpreter for error reporting. */
1440 int varIndex) /* Index of the test variable to check. */
1441 {
1442 if (varPtr[varIndex] == NULL) {
1443 char buf[32 + TCL_INTEGER_SPACE];
1444
1445 sprintf(buf, "variable %d is unset (NULL)", varIndex);
1446 Tcl_ResetResult(interp);
1447 Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
1448 return 1;
1449 }
1450 return 0;
1451 }
1452
1453 /*
1454 * Local Variables:
1455 * mode: c
1456 * c-basic-offset: 4
1457 * fill-column: 78
1458 * End:
1459 */
1460