Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Overview
Comment: | more result generation conversion |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors | descendants | both | trunk |
Files: | files | file ages | folders |
SHA1: |
9a036eff3aa8dda0dba82ddcb110bd11 |
User & Date: | dkf 2012-08-04 07:41:11 |
Context
2012-08-04
| ||
12:09 | Reduce the amount of ifdeffery somewhat by requiring at least OSX Tiger. That's now everyone we care... check-in: 1a67b9c45a user: dkf tags: trunk | |
07:52 | merge trunk Closed-Leaf check-in: 87af801de3 user: dkf tags: dkf-utf16-branch | |
07:51 | merge trunk Closed-Leaf check-in: d203e314d8 user: dkf tags: dkf-notifier-poll | |
07:49 | merge trunk check-in: 680fa63bf7 user: dkf tags: dkf-http-cookies | |
07:48 | merge trunk Leaf check-in: 0e556bddf4 user: dkf tags: dkf-documentation-figures | |
07:47 | merge trunk check-in: 942e699a9b user: dkf tags: dkf-bytecode-8.6-main | |
07:46 | merge trunk Closed-Leaf check-in: cd8e483be3 user: dkf tags: dkf-alias-encoding | |
07:41 | more result generation conversion check-in: 9a036eff3a user: dkf tags: trunk | |
2012-08-03
| ||
14:24 | more result generation conversion check-in: b3ccaec093 user: dkf tags: trunk | |
Changes
Changes to generic/tclInterp.c.
︙ | ︙ | |||
1039 1040 1041 1042 1043 1044 1045 | } aliasName = TclGetString(objv[3]); iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo; hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName); if (hPtr == NULL) { | | > | | | < | | 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 | } aliasName = TclGetString(objv[3]); iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo; hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName); if (hPtr == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "alias \"%s\" in path \"%s\" not found", aliasName, Tcl_GetString(objv[2]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", aliasName, NULL); return TCL_ERROR; } aliasPtr = Tcl_GetHashValue(hPtr); if (Tcl_GetInterpPath(interp, aliasPtr->targetInterp) != TCL_OK) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "target interpreter for alias \"%s\" in path \"%s\" is " "not my descendant", aliasName, Tcl_GetString(objv[2]))); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "TARGETSHROUDED", NULL); return TCL_ERROR; } return TCL_OK; } } |
︙ | ︙ | |||
1230 1231 1232 1233 1234 1235 1236 | Tcl_HashEntry *hPtr; Alias *aliasPtr; int i, objc; Tcl_Obj **objv; hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName); if (hPtr == NULL) { | | > | 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 | Tcl_HashEntry *hPtr; Alias *aliasPtr; int i, objc; Tcl_Obj **objv; hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName); if (hPtr == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "alias \"%s\" not found", aliasName)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", aliasName, NULL); return TCL_ERROR; } aliasPtr = Tcl_GetHashValue(hPtr); objc = aliasPtr->objc; objv = &aliasPtr->objPtr; |
︙ | ︙ | |||
1291 1292 1293 1294 1295 1296 1297 | Tcl_HashEntry *hPtr; Alias *aliasPtr; int objc; Tcl_Obj **objv; hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName); if (hPtr == NULL) { | | > | 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 | Tcl_HashEntry *hPtr; Alias *aliasPtr; int objc; Tcl_Obj **objv; hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName); if (hPtr == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "alias \"%s\" not found", aliasName)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", aliasName, NULL); return TCL_ERROR; } aliasPtr = Tcl_GetHashValue(hPtr); objc = aliasPtr->objc; objv = &aliasPtr->objPtr; |
︙ | ︙ | |||
1379 1380 1381 1382 1383 1384 1385 | if (Tcl_InterpDeleted(nextAliasPtr->targetInterp)) { /* * The slave interpreter can be deleted while creating the alias. * [Bug #641195] */ | > | | < > | | < | 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 | if (Tcl_InterpDeleted(nextAliasPtr->targetInterp)) { /* * The slave interpreter can be deleted while creating the alias. * [Bug #641195] */ Tcl_SetObjResult(interp, Tcl_ObjPrintf( "cannot define or rename alias \"%s\": interpreter deleted", Tcl_GetCommandName(cmdInterp, cmd))); return TCL_ERROR; } cmdNamePtr = nextAliasPtr->objPtr; aliasCmd = Tcl_FindCommand(nextAliasPtr->targetInterp, TclGetString(cmdNamePtr), Tcl_GetGlobalNamespace(nextAliasPtr->targetInterp), /*flags*/ 0); if (aliasCmd == NULL) { return TCL_OK; } aliasCmdPtr = (Command *) aliasCmd; if (aliasCmdPtr == cmdPtr) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "cannot define or rename alias \"%s\": would create a loop", Tcl_GetCommandName(cmdInterp, cmd))); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "ALIASLOOP", NULL); return TCL_ERROR; } /* * Otherwise, follow the chain one step further. See if the target |
︙ | ︙ | |||
1617 1618 1619 1620 1621 1622 1623 | * the original name (with which it was created) to find the alias to * delete it. */ slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave; hPtr = Tcl_FindHashEntry(&slavePtr->aliasTable, TclGetString(namePtr)); if (hPtr == NULL) { | | | | 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 | * the original name (with which it was created) to find the alias to * delete it. */ slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave; hPtr = Tcl_FindHashEntry(&slavePtr->aliasTable, TclGetString(namePtr)); if (hPtr == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "alias \"%s\" not found", TclGetString(namePtr))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", TclGetString(namePtr), NULL); return TCL_ERROR; } aliasPtr = Tcl_GetHashValue(hPtr); Tcl_DeleteCommandFromToken(slaveInterp, aliasPtr->slaveCmd); return TCL_OK; |
︙ | ︙ | |||
2216 2217 2218 2219 2220 2221 2222 | slavePtr = Tcl_GetHashValue(hPtr); searchInterp = slavePtr->slaveInterp; if (searchInterp == NULL) { break; } } if (searchInterp == NULL) { | | | | 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 | slavePtr = Tcl_GetHashValue(hPtr); searchInterp = slavePtr->slaveInterp; if (searchInterp == NULL) { break; } } if (searchInterp == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "could not find interpreter \"%s\"", TclGetString(pathPtr))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INTERP", TclGetString(pathPtr), NULL); } return searchInterp; } /* |
︙ | ︙ | |||
2254 2255 2256 2257 2258 2259 2260 | Tcl_Obj *const objv[]) /* Argument strings. */ { if (objc) { int length; if (TCL_ERROR == TclListObjLength(NULL, objv[0], &length) || (length < 1)) { | > | < | 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 | Tcl_Obj *const objv[]) /* Argument strings. */ { if (objc) { int length; if (TCL_ERROR == TclListObjLength(NULL, objv[0], &length) || (length < 1)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "cmdPrefix must be list of length >= 1", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "BGERRORFORMAT", NULL); return TCL_ERROR; } TclSetBgErrorHandler(slaveInterp, objv[0]); } Tcl_SetObjResult(interp, TclGetBgErrorHandler(slaveInterp)); |
︙ | ︙ | |||
2324 2325 2326 2327 2328 2329 2330 | safe = Tcl_IsSafe(masterInterp); } masterInfoPtr = (InterpInfo *) ((Interp *) masterInterp)->interpInfo; hPtr = Tcl_CreateHashEntry(&masterInfoPtr->master.slaveTable, path, &isNew); if (isNew == 0) { | | | > | 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 | safe = Tcl_IsSafe(masterInterp); } masterInfoPtr = (InterpInfo *) ((Interp *) masterInterp)->interpInfo; hPtr = Tcl_CreateHashEntry(&masterInfoPtr->master.slaveTable, path, &isNew); if (isNew == 0) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "interpreter named \"%s\" already exists, cannot create", path)); return NULL; } slaveInterp = Tcl_CreateInterp(); slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave; slavePtr->masterInterp = masterInterp; slavePtr->slaveEntryPtr = hPtr; |
︙ | ︙ | |||
2858 2859 2860 2861 2862 2863 2864 | Tcl_Obj *const objv[]) /* Argument strings. */ { Interp *iPtr; int limit; if (objc) { if (Tcl_IsSafe(interp)) { | | | | 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 | Tcl_Obj *const objv[]) /* Argument strings. */ { Interp *iPtr; int limit; if (objc) { if (Tcl_IsSafe(interp)) { Tcl_SetObjResult(interp, Tcl_NewStringObj("permission denied: " "safe interpreters cannot change recursion limit", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE", NULL); return TCL_ERROR; } if (TclGetIntFromObj(interp, objv[0], &limit) == TCL_ERROR) { return TCL_ERROR; } |
︙ | ︙ | |||
3318 3319 3320 3321 3322 3323 3324 | (iPtr->limit.cmdCount < iPtr->cmdCount)) { iPtr->limit.exceeded |= TCL_LIMIT_COMMANDS; Tcl_Preserve(interp); RunLimitHandlers(iPtr->limit.cmdHandlers, interp); if (iPtr->limit.cmdCount >= iPtr->cmdCount) { iPtr->limit.exceeded &= ~TCL_LIMIT_COMMANDS; } else if (iPtr->limit.exceeded & TCL_LIMIT_COMMANDS) { | | | | 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 | (iPtr->limit.cmdCount < iPtr->cmdCount)) { iPtr->limit.exceeded |= TCL_LIMIT_COMMANDS; Tcl_Preserve(interp); RunLimitHandlers(iPtr->limit.cmdHandlers, interp); if (iPtr->limit.cmdCount >= iPtr->cmdCount) { iPtr->limit.exceeded &= ~TCL_LIMIT_COMMANDS; } else if (iPtr->limit.exceeded & TCL_LIMIT_COMMANDS) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "command count limit exceeded", -1)); Tcl_SetErrorCode(interp, "TCL", "LIMIT", "COMMANDS", NULL); Tcl_Release(interp); return TCL_ERROR; } Tcl_Release(interp); } |
︙ | ︙ | |||
3344 3345 3346 3347 3348 3349 3350 | Tcl_Preserve(interp); RunLimitHandlers(iPtr->limit.timeHandlers, interp); if (iPtr->limit.time.sec > now.sec || (iPtr->limit.time.sec == now.sec && iPtr->limit.time.usec >= now.usec)) { iPtr->limit.exceeded &= ~TCL_LIMIT_TIME; } else if (iPtr->limit.exceeded & TCL_LIMIT_TIME) { | | | | 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 | Tcl_Preserve(interp); RunLimitHandlers(iPtr->limit.timeHandlers, interp); if (iPtr->limit.time.sec > now.sec || (iPtr->limit.time.sec == now.sec && iPtr->limit.time.usec >= now.usec)) { iPtr->limit.exceeded &= ~TCL_LIMIT_TIME; } else if (iPtr->limit.exceeded & TCL_LIMIT_TIME) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "time limit exceeded", -1)); Tcl_SetErrorCode(interp, "TCL", "LIMIT", "TIME", NULL); Tcl_Release(interp); return TCL_ERROR; } Tcl_Release(interp); } } |
︙ | ︙ | |||
4351 4352 4353 4354 4355 4356 4357 | * First, ensure that we are not reading or writing the calling * interpreter's limits; it may only manipulate its children. Note that * the low level API enforces this with Tcl_Panic, which we want to * avoid. [Bug 3398794] */ if (interp == slaveInterp) { | | | > | 4354 4355 4356 4357 4358 4359 4360 4361 4362 4363 4364 4365 4366 4367 4368 4369 4370 | * First, ensure that we are not reading or writing the calling * interpreter's limits; it may only manipulate its children. Note that * the low level API enforces this with Tcl_Panic, which we want to * avoid. [Bug 3398794] */ if (interp == slaveInterp) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "limits on current interpreter inaccessible", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "SELF", NULL); return TCL_ERROR; } if (objc == consumedObjc) { Tcl_Obj *dictPtr; TclNewObj(dictPtr); |
︙ | ︙ | |||
4448 4449 4450 4451 4452 4453 4454 | break; case OPT_GRAN: granObj = objv[i+1]; if (TclGetIntFromObj(interp, objv[i+1], &gran) != TCL_OK) { return TCL_ERROR; } if (gran < 1) { | | | > | < | 4452 4453 4454 4455 4456 4457 4458 4459 4460 4461 4462 4463 4464 4465 4466 4467 4468 4469 4470 4471 4472 4473 4474 4475 4476 4477 4478 4479 4480 4481 4482 4483 4484 | break; case OPT_GRAN: granObj = objv[i+1]; if (TclGetIntFromObj(interp, objv[i+1], &gran) != TCL_OK) { return TCL_ERROR; } if (gran < 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "granularity must be at least 1", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "BADVALUE", NULL); return TCL_ERROR; } break; case OPT_VAL: limitObj = objv[i+1]; (void) Tcl_GetStringFromObj(objv[i+1], &limitLen); if (limitLen == 0) { break; } if (TclGetIntFromObj(interp, objv[i+1], &limit) != TCL_OK) { return TCL_ERROR; } if (limit < 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "command limit value must be at least 0", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "BADVALUE", NULL); return TCL_ERROR; } break; } } |
︙ | ︙ | |||
4538 4539 4540 4541 4542 4543 4544 | * First, ensure that we are not reading or writing the calling * interpreter's limits; it may only manipulate its children. Note that * the low level API enforces this with Tcl_Panic, which we want to * avoid. [Bug 3398794] */ if (interp == slaveInterp) { | | | > | 4542 4543 4544 4545 4546 4547 4548 4549 4550 4551 4552 4553 4554 4555 4556 4557 4558 | * First, ensure that we are not reading or writing the calling * interpreter's limits; it may only manipulate its children. Note that * the low level API enforces this with Tcl_Panic, which we want to * avoid. [Bug 3398794] */ if (interp == slaveInterp) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "limits on current interpreter inaccessible", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "SELF", NULL); return TCL_ERROR; } if (objc == consumedObjc) { Tcl_Obj *dictPtr; TclNewObj(dictPtr); |
︙ | ︙ | |||
4656 4657 4658 4659 4660 4661 4662 | break; case OPT_GRAN: granObj = objv[i+1]; if (TclGetIntFromObj(interp, objv[i+1], &gran) != TCL_OK) { return TCL_ERROR; } if (gran < 1) { | | | > | < | > | < > | | > | | | 4661 4662 4663 4664 4665 4666 4667 4668 4669 4670 4671 4672 4673 4674 4675 4676 4677 4678 4679 4680 4681 4682 4683 4684 4685 4686 4687 4688 4689 4690 4691 4692 4693 4694 4695 4696 4697 4698 4699 4700 4701 4702 4703 4704 4705 4706 4707 4708 4709 4710 4711 4712 4713 4714 4715 4716 4717 4718 4719 4720 4721 4722 4723 4724 4725 4726 4727 4728 4729 4730 4731 4732 4733 4734 4735 4736 4737 4738 | break; case OPT_GRAN: granObj = objv[i+1]; if (TclGetIntFromObj(interp, objv[i+1], &gran) != TCL_OK) { return TCL_ERROR; } if (gran < 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "granularity must be at least 1", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "BADVALUE", NULL); return TCL_ERROR; } break; case OPT_MILLI: milliObj = objv[i+1]; (void) Tcl_GetStringFromObj(objv[i+1], &milliLen); if (milliLen == 0) { break; } if (TclGetIntFromObj(interp, objv[i+1], &tmp) != TCL_OK) { return TCL_ERROR; } if (tmp < 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "milliseconds must be at least 0", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "BADVALUE", NULL); return TCL_ERROR; } limitMoment.usec = ((long) tmp)*1000; break; case OPT_SEC: secObj = objv[i+1]; (void) Tcl_GetStringFromObj(objv[i+1], &secLen); if (secLen == 0) { break; } if (TclGetIntFromObj(interp, objv[i+1], &tmp) != TCL_OK) { return TCL_ERROR; } if (tmp < 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "seconds must be at least 0", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "BADVALUE", NULL); return TCL_ERROR; } limitMoment.sec = tmp; break; } } if (milliObj != NULL || secObj != NULL) { if (milliObj != NULL) { /* * Setting -milliseconds but clearing -seconds, or resetting * -milliseconds but not resetting -seconds? Bad voodoo! */ if (secObj != NULL && secLen == 0 && milliLen > 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "may only set -milliseconds if -seconds is not " "also being reset", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "BADUSAGE", NULL); return TCL_ERROR; } if (milliLen == 0 && (secObj == NULL || secLen > 0)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "may only reset -milliseconds if -seconds is " "also being reset", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "BADUSAGE", NULL); return TCL_ERROR; } } if (milliLen > 0 || secLen > 0) { |
︙ | ︙ |
Changes to generic/tclLoad.c.
︙ | ︙ | |||
220 221 222 223 224 225 226 | defaultPtr = pkgPtr; } if (filesMatch && !namesMatch && (fullFileName[0] != 0)) { /* * Can't have two different packages loaded from the same file. */ | | | | | 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 | defaultPtr = pkgPtr; } if (filesMatch && !namesMatch && (fullFileName[0] != 0)) { /* * Can't have two different packages loaded from the same file. */ Tcl_SetObjResult(interp, Tcl_ObjPrintf( "file \"%s\" is already loaded for package \"%s\"", fullFileName, pkgPtr->packageName)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "SPLITPERSONALITY", NULL); code = TCL_ERROR; Tcl_MutexUnlock(&packageMutex); goto done; } } |
︙ | ︙ | |||
258 259 260 261 262 263 264 | if (pkgPtr == NULL) { /* * The desired file isn't currently loaded, so load it. It's an error * if the desired package is a static one. */ if (fullFileName[0] == 0) { | | | | 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 | if (pkgPtr == NULL) { /* * The desired file isn't currently loaded, so load it. It's an error * if the desired package is a static one. */ if (fullFileName[0] == 0) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "package \"%s\" isn't loaded statically", packageName)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "NOTSTATIC", NULL); code = TCL_ERROR; goto done; } /* |
︙ | ︙ | |||
316 317 318 319 320 321 322 | || !(isalpha(UCHAR(ch)) /* INTL: ISO only */ || (UCHAR(ch) == '_'))) { break; } } if (p == pkgGuess) { Tcl_DecrRefCount(splitPtr); | | | | | 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 | || !(isalpha(UCHAR(ch)) /* INTL: ISO only */ || (UCHAR(ch) == '_'))) { break; } } if (p == pkgGuess) { Tcl_DecrRefCount(splitPtr); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't figure out package name for %s", fullFileName)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "WHATPACKAGE", NULL); code = TCL_ERROR; goto done; } Tcl_DStringAppend(&pkgName, pkgGuess, p - pkgGuess); Tcl_DecrRefCount(splitPtr); |
︙ | ︙ | |||
413 414 415 416 417 418 419 | /* * Invoke the package's initialization function (either the normal one or * the safe one, depending on whether or not the interpreter is safe). */ if (Tcl_IsSafe(target)) { if (pkgPtr->safeInitProc == NULL) { | | | | | | | | 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 | /* * Invoke the package's initialization function (either the normal one or * the safe one, depending on whether or not the interpreter is safe). */ if (Tcl_IsSafe(target)) { if (pkgPtr->safeInitProc == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't use package in a safe interpreter: no" " %s_SafeInit procedure", pkgPtr->packageName)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "UNSAFE", NULL); code = TCL_ERROR; goto done; } code = pkgPtr->safeInitProc(target); } else { if (pkgPtr->initProc == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't attach package to interpreter: no %s_Init procedure", pkgPtr->packageName)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "ENTRYPOINT", NULL); code = TCL_ERROR; goto done; } code = pkgPtr->initProc(target); } |
︙ | ︙ | |||
649 650 651 652 653 654 655 | } Tcl_MutexUnlock(&packageMutex); if (fullFileName[0] == 0) { /* * It's an error to try unload a static package. */ | | | > | | | 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 | } Tcl_MutexUnlock(&packageMutex); if (fullFileName[0] == 0) { /* * It's an error to try unload a static package. */ Tcl_SetObjResult(interp, Tcl_ObjPrintf( "package \"%s\" is loaded statically and cannot be unloaded", packageName)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "STATIC", NULL); code = TCL_ERROR; goto done; } if (pkgPtr == NULL) { /* * The DLL pointed by the provided filename has never been loaded. */ Tcl_SetObjResult(interp, Tcl_ObjPrintf( "file \"%s\" has never been loaded", fullFileName)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "NEVERLOADED", NULL); code = TCL_ERROR; goto done; } /* |
︙ | ︙ | |||
690 691 692 693 694 695 696 | } } if (code != TCL_OK) { /* * The package has not been loaded in this interpreter. */ | | | > | | > | | > | 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 | } } if (code != TCL_OK) { /* * The package has not been loaded in this interpreter. */ Tcl_SetObjResult(interp, Tcl_ObjPrintf( "file \"%s\" has never been loaded in this interpreter", fullFileName)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "NEVERLOADED", NULL); code = TCL_ERROR; goto done; } /* * Ensure that the DLL can be unloaded. If it is a trusted interpreter, * pkgPtr->unloadProc must not be NULL for the DLL to be unloadable. If * the interpreter is a safe one, pkgPtr->safeUnloadProc must be non-NULL. */ if (Tcl_IsSafe(target)) { if (pkgPtr->safeUnloadProc == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "file \"%s\" cannot be unloaded under a safe interpreter", fullFileName)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "CANNOT", NULL); code = TCL_ERROR; goto done; } unloadProc = pkgPtr->safeUnloadProc; } else { if (pkgPtr->unloadProc == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "file \"%s\" cannot be unloaded under a trusted interpreter", fullFileName)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "CANNOT", NULL); code = TCL_ERROR; goto done; } unloadProc = pkgPtr->unloadProc; } |
︙ | ︙ | |||
856 857 858 859 860 861 862 | ckfree(ipPtr); Tcl_MutexUnlock(&packageMutex); } else { code = TCL_ERROR; } } #else | | | > | 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 | ckfree(ipPtr); Tcl_MutexUnlock(&packageMutex); } else { code = TCL_ERROR; } } #else Tcl_SetObjResult(interp, Tcl_ObjPrintf( "file \"%s\" cannot be unloaded: unloading disabled", fullFileName)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "DISABLED", NULL); code = TCL_ERROR; #endif } done: |
︙ | ︙ |
Changes to generic/tclNamesp.c.
︙ | ︙ | |||
683 684 685 686 687 688 689 | * Treat this namespace as the global namespace, and avoid looking for * a parent. */ parentPtr = NULL; simpleName = ""; } else if (*name == '\0') { | < | | | 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 | * Treat this namespace as the global namespace, and avoid looking for * a parent. */ parentPtr = NULL; simpleName = ""; } else if (*name == '\0') { Tcl_SetObjResult(interp, Tcl_NewStringObj("can't create namespace" " \"\": only global namespace can have empty name", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE", "CREATEGLOBAL", NULL); return NULL; } else { /* * Find the parent for the new namespace. */ |
︙ | ︙ | |||
721 722 723 724 725 726 727 | #ifndef BREAK_NAMESPACE_COMPAT Tcl_FindHashEntry(&parentPtr->childTable, simpleName) != NULL #else parentPtr->childTablePtr != NULL && Tcl_FindHashEntry(parentPtr->childTablePtr, simpleName) != NULL #endif ) { | | | | 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 | #ifndef BREAK_NAMESPACE_COMPAT Tcl_FindHashEntry(&parentPtr->childTable, simpleName) != NULL #else parentPtr->childTablePtr != NULL && Tcl_FindHashEntry(parentPtr->childTablePtr, simpleName) != NULL #endif ) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't create namespace \"%s\": already exists", name)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE", "CREATEEXISTING", NULL); return NULL; } } /* |
︙ | ︙ | |||
1332 1333 1334 1335 1336 1337 1338 | */ TclGetNamespaceForQualName(interp, pattern, nsPtr, /*flags*/ (TCL_LEAVE_ERR_MSG | TCL_NAMESPACE_ONLY), &exportNsPtr, &dummyPtr, &dummyPtr, &simplePattern); if ((exportNsPtr != nsPtr) || (strcmp(pattern, simplePattern) != 0)) { | | | | 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 | */ TclGetNamespaceForQualName(interp, pattern, nsPtr, /*flags*/ (TCL_LEAVE_ERR_MSG | TCL_NAMESPACE_ONLY), &exportNsPtr, &dummyPtr, &dummyPtr, &simplePattern); if ((exportNsPtr != nsPtr) || (strcmp(pattern, simplePattern) != 0)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf("invalid export pattern" " \"%s\": pattern can't specify a namespace", pattern)); Tcl_SetErrorCode(interp, "TCL", "EXPORT", "INVALID", NULL); return TCL_ERROR; } /* * Make sure that we don't already have the pattern in the array */ |
︙ | ︙ | |||
1547 1548 1549 1550 1551 1552 1553 | return TCL_ERROR; } TclGetNamespaceForQualName(interp, pattern, nsPtr, /*flags*/ (TCL_LEAVE_ERR_MSG | TCL_NAMESPACE_ONLY), &importNsPtr, &dummyPtr, &dummyPtr, &simplePattern); if (importNsPtr == NULL) { | > | < | | | | | | | 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 | return TCL_ERROR; } TclGetNamespaceForQualName(interp, pattern, nsPtr, /*flags*/ (TCL_LEAVE_ERR_MSG | TCL_NAMESPACE_ONLY), &importNsPtr, &dummyPtr, &dummyPtr, &simplePattern); if (importNsPtr == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unknown namespace in import pattern \"%s\"", pattern)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", pattern, NULL); return TCL_ERROR; } if (importNsPtr == nsPtr) { if (pattern == simplePattern) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "no namespace specified in import pattern \"%s\"", pattern)); Tcl_SetErrorCode(interp, "TCL", "IMPORT", "ORIGIN", NULL); } else { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "import pattern \"%s\" tries to import from namespace" " \"%s\" into itself", pattern, importNsPtr->name)); Tcl_SetErrorCode(interp, "TCL", "IMPORT", "SELF", NULL); } return TCL_ERROR; } /* * Scan through the command table in the source namespace and look for |
︙ | ︙ | |||
1680 1681 1682 1683 1684 1685 1686 | Command *overwrite = Tcl_GetHashValue(found); Command *linkCmd = cmdPtr; while (linkCmd->deleteProc == DeleteImportedCmd) { dataPtr = linkCmd->objClientData; linkCmd = dataPtr->realCmdPtr; if (overwrite == linkCmd) { | > | | | | 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 | Command *overwrite = Tcl_GetHashValue(found); Command *linkCmd = cmdPtr; while (linkCmd->deleteProc == DeleteImportedCmd) { dataPtr = linkCmd->objClientData; linkCmd = dataPtr->realCmdPtr; if (overwrite == linkCmd) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "import pattern \"%s\" would create a loop" " containing command \"%s\"", pattern, Tcl_DStringValue(&ds))); Tcl_DStringFree(&ds); Tcl_SetErrorCode(interp, "TCL", "IMPORT", "LOOP", NULL); return TCL_ERROR; } } } |
︙ | ︙ | |||
1722 1723 1724 1725 1726 1727 1728 | /* * Repeated import of same command is acceptable. */ return TCL_OK; } } | | | | 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 | /* * Repeated import of same command is acceptable. */ return TCL_OK; } } Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't import command \"%s\": already exists", cmdName)); Tcl_SetErrorCode(interp, "TCL", "IMPORT", "OVERWRITE", NULL); return TCL_ERROR; } return TCL_OK; } /* |
︙ | ︙ | |||
1792 1793 1794 1795 1796 1797 1798 | */ TclGetNamespaceForQualName(interp, pattern, nsPtr, /*flags*/ (TCL_LEAVE_ERR_MSG | TCL_NAMESPACE_ONLY), &sourceNsPtr, &dummyPtr, &dummyPtr, &simplePattern); if (sourceNsPtr == NULL) { | | | | | 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 | */ TclGetNamespaceForQualName(interp, pattern, nsPtr, /*flags*/ (TCL_LEAVE_ERR_MSG | TCL_NAMESPACE_ONLY), &sourceNsPtr, &dummyPtr, &dummyPtr, &simplePattern); if (sourceNsPtr == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unknown namespace in namespace forget pattern \"%s\"", pattern)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", pattern, NULL); return TCL_ERROR; } if (strcmp(pattern, simplePattern) == 0) { /* * The pattern is simple. Delete any imported commands that match it. |
︙ | ︙ | |||
2398 2399 2400 2401 2402 2403 2404 | flags|TCL_FIND_ONLY_NS, &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy); if (nsPtr != NULL) { return (Tcl_Namespace *) nsPtr; } if (flags & TCL_LEAVE_ERR_MSG) { | | | | 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 | flags|TCL_FIND_ONLY_NS, &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy); if (nsPtr != NULL) { return (Tcl_Namespace *) nsPtr; } if (flags & TCL_LEAVE_ERR_MSG) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unknown namespace \"%s\"", name)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", name, NULL); } return NULL; } /* *---------------------------------------------------------------------- |
︙ | ︙ | |||
2585 2586 2587 2588 2589 2590 2591 | } if (cmdPtr != NULL) { return (Tcl_Command) cmdPtr; } if (flags & TCL_LEAVE_ERR_MSG) { | | | | 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 | } if (cmdPtr != NULL) { return (Tcl_Command) cmdPtr; } if (flags & TCL_LEAVE_ERR_MSG) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unknown command \"%s\"", name)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", name, NULL); } return NULL; } /* *---------------------------------------------------------------------- |
︙ | ︙ | |||
3166 3167 3168 3169 3170 3171 3172 | */ for (i = 1; i < objc; i++) { name = TclGetString(objv[i]); namespacePtr = Tcl_FindNamespace(interp, name, NULL, /*flags*/ 0); if ((namespacePtr == NULL) || (((Namespace *) namespacePtr)->flags & NS_KILLED)) { | > | | < | 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 | */ for (i = 1; i < objc; i++) { name = TclGetString(objv[i]); namespacePtr = Tcl_FindNamespace(interp, name, NULL, /*flags*/ 0); if ((namespacePtr == NULL) || (((Namespace *) namespacePtr)->flags & NS_KILLED)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unknown namespace \"%s\" in namespace delete command", TclGetString(objv[i]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", TclGetString(objv[i]), NULL); return TCL_ERROR; } } /* |
︙ | ︙ | |||
3830 3831 3832 3833 3834 3835 3836 | if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "name"); return TCL_ERROR; } command = Tcl_GetCommandFromObj(interp, objv[1]); if (command == NULL) { | | | | 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 | if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "name"); return TCL_ERROR; } command = Tcl_GetCommandFromObj(interp, objv[1]); if (command == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "invalid command name \"%s\"", TclGetString(objv[1]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", TclGetString(objv[1]), NULL); return TCL_ERROR; } origCommand = TclGetOriginalCommand(command); TclNewObj(resultPtr); if (origCommand == NULL) { |
︙ | ︙ |
Changes to generic/tclObj.c.
︙ | ︙ | |||
4458 4459 4460 4461 4462 4463 4464 | int Tcl_RepresentationCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { | | | < < < < | | > | > | | | | | | > < < | | | > | > > | 4458 4459 4460 4461 4462 4463 4464 4465 4466 4467 4468 4469 4470 4471 4472 4473 4474 4475 4476 4477 4478 4479 4480 4481 4482 4483 4484 4485 4486 4487 4488 4489 4490 4491 4492 4493 4494 4495 4496 4497 4498 4499 4500 4501 4502 4503 4504 4505 4506 4507 4508 4509 | int Tcl_RepresentationCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { char ptrBuffer[2*TCL_INTEGER_SPACE+6]; Tcl_Obj *descObj; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "value"); return TCL_ERROR; } /* * Value is a bignum with a refcount of 14, object pointer at 0x12345678, * internal representation 0x45671234:0x98765432, string representation * "1872361827361287" */ sprintf(ptrBuffer, "%p", (void *) objv[1]); descObj = Tcl_ObjPrintf("value is a %s with a refcount of %d," " object pointer at %s", objv[1]->typePtr ? objv[1]->typePtr->name : "pure string", objv[1]->refCount, ptrBuffer); if (objv[1]->typePtr) { sprintf(ptrBuffer, "%p:%p", (void *) objv[1]->internalRep.twoPtrValue.ptr1, (void *) objv[1]->internalRep.twoPtrValue.ptr2); Tcl_AppendPrintfToObj(descObj, ", internal representation %s", ptrBuffer); } if (objv[1]->bytes) { Tcl_AppendToObj(descObj, ", string representation \"", -1); Tcl_AppendLimitedToObj(descObj, objv[1]->bytes, objv[1]->length, 16, "..."); Tcl_AppendToObj(descObj, "\"", -1); } else { Tcl_AppendToObj(descObj, ", no string representation", -1); } Tcl_SetObjResult(interp, descObj); return TCL_OK; } /* * Local Variables: * mode: c * c-basic-offset: 4 |
︙ | ︙ |
Changes to generic/tclPipe.c.
︙ | ︙ | |||
102 103 104 105 106 107 108 | if (file == NULL) { Tcl_Obj *msg; Tcl_GetChannelError(chan, &msg); if (msg) { Tcl_SetObjResult(interp, msg); } else { | | > | | | 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 | if (file == NULL) { Tcl_Obj *msg; Tcl_GetChannelError(chan, &msg); if (msg) { Tcl_SetObjResult(interp, msg); } else { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "channel \"%s\" wasn't opened for %s", Tcl_GetChannelName(chan), ((writing) ? "writing" : "reading"))); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "BADCHAN", NULL); } return NULL; } *releasePtr = 1; if (writing) { |
︙ | ︙ | |||
137 138 139 140 141 142 143 | name = Tcl_TranslateFileName(interp, spec, &nameString); if (name == NULL) { return NULL; } file = TclpOpenFile(name, flags); Tcl_DStringFree(&nameString); if (file == NULL) { | | > | | | | | 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 | name = Tcl_TranslateFileName(interp, spec, &nameString); if (name == NULL) { return NULL; } file = TclpOpenFile(name, flags); Tcl_DStringFree(&nameString); if (file == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't %s file \"%s\": %s", (writing ? "write" : "read"), spec, Tcl_PosixError(interp))); return NULL; } *closePtr = 1; } return file; badLastArg: Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't specify \"%s\" as last word in command", arg)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "SYNTAX", NULL); return NULL; } /* *---------------------------------------------------------------------- * |
︙ | ︙ | |||
300 301 302 303 304 305 306 | * remind people that ECHILD errors can occur on some * systems if SIGCHLD isn't in its default state. */ msg = "child process lost (is SIGCHLD ignored or trapped?)"; } | > | < | 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 | * remind people that ECHILD errors can occur on some * systems if SIGCHLD isn't in its default state. */ msg = "child process lost (is SIGCHLD ignored or trapped?)"; } Tcl_SetObjResult(interp, Tcl_ObjPrintf( "error waiting for process to exit: %s", msg)); } continue; } /* * Create error messages for unusual process exits. An extra newline * gets appended to each error message, but it gets removed below (in |
︙ | ︙ | |||
331 332 333 334 335 336 337 | } else if (interp != NULL) { const char *p; if (WIFSIGNALED(waitStatus)) { p = Tcl_SignalMsg(WTERMSIG(waitStatus)); Tcl_SetErrorCode(interp, "CHILDKILLED", msg1, Tcl_SignalId(WTERMSIG(waitStatus)), p, NULL); | > | > | < | | | 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 | } else if (interp != NULL) { const char *p; if (WIFSIGNALED(waitStatus)) { p = Tcl_SignalMsg(WTERMSIG(waitStatus)); Tcl_SetErrorCode(interp, "CHILDKILLED", msg1, Tcl_SignalId(WTERMSIG(waitStatus)), p, NULL); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "child killed: %s\n", p)); } else if (WIFSTOPPED(waitStatus)) { p = Tcl_SignalMsg(WSTOPSIG(waitStatus)); Tcl_SetErrorCode(interp, "CHILDSUSP", msg1, Tcl_SignalId(WSTOPSIG(waitStatus)), p, NULL); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "child suspended: %s\n", p)); } else { Tcl_SetObjResult(interp, Tcl_NewStringObj( "child wait status didn't make sense\n", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "ODDWAITRESULT", msg1, NULL); } } } } |
︙ | ︙ | |||
370 371 372 373 374 375 376 | Tcl_Seek(errorChan, (Tcl_WideInt)0, SEEK_SET); objPtr = Tcl_NewObj(); count = Tcl_ReadChars(errorChan, objPtr, -1, 0); if (count < 0) { result = TCL_ERROR; Tcl_DecrRefCount(objPtr); Tcl_ResetResult(interp); | > | | > | | 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 | Tcl_Seek(errorChan, (Tcl_WideInt)0, SEEK_SET); objPtr = Tcl_NewObj(); count = Tcl_ReadChars(errorChan, objPtr, -1, 0); if (count < 0) { result = TCL_ERROR; Tcl_DecrRefCount(objPtr); Tcl_ResetResult(interp); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "error reading stderr output file: %s", Tcl_PosixError(interp))); } else if (count > 0) { anyErrorInfo = 1; Tcl_SetObjResult(interp, objPtr); result = TCL_ERROR; } else { Tcl_DecrRefCount(objPtr); } } Tcl_Close(NULL, errorChan); } /* * If a child exited abnormally but didn't output any error information at * all, generate an error message here. */ if ((abnormalExit != 0) && (anyErrorInfo == 0) && (interp != NULL)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "child process exited abnormally", -1)); } return result; } /* *---------------------------------------------------------------------- * |
︙ | ︙ | |||
566 567 568 569 570 571 572 | if (*p == '<') { inputFile = NULL; inputLiteral = p + 1; skip = 1; if (*inputLiteral == '\0') { inputLiteral = ((i + 1) == argc) ? NULL : argv[i + 1]; if (inputLiteral == NULL) { | | | > | 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 | if (*p == '<') { inputFile = NULL; inputLiteral = p + 1; skip = 1; if (*inputLiteral == '\0') { inputLiteral = ((i + 1) == argc) ? NULL : argv[i + 1]; if (inputLiteral == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't specify \"%s\" as last word in command", argv[i])); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "PIPESYNTAX", NULL); goto error; } skip = 2; } } else { |
︙ | ︙ | |||
676 677 678 679 680 681 682 | /* * Special case handling of 2>@1 to redirect stderr to the * exec/open output pipe as well. This is meant for the end of * the command string, otherwise use |& between commands. */ if (i != argc-1) { | | | > | 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 | /* * Special case handling of 2>@1 to redirect stderr to the * exec/open output pipe as well. This is meant for the end of * the command string, otherwise use |& between commands. */ if (i != argc-1) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "must specify \"%s\" as last word in command", argv[i])); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "PIPESYNTAX", NULL); goto error; } errorFile = outputFile; errorToOutput = 2; skip = 1; |
︙ | ︙ | |||
735 736 737 738 739 740 741 | * The input for the first process is immediate data coming from * Tcl. Create a temporary file for it and put the data into the * file. */ inputFile = TclpCreateTempFile(inputLiteral); if (inputFile == NULL) { | | | | | | | | 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 | * The input for the first process is immediate data coming from * Tcl. Create a temporary file for it and put the data into the * file. */ inputFile = TclpCreateTempFile(inputLiteral); if (inputFile == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't create input file for command: %s", Tcl_PosixError(interp))); goto error; } inputClose = 1; } else if (inPipePtr != NULL) { /* * The input for the first process in the pipeline is to come from * a pipe that can be written from by the caller. */ if (TclpCreatePipe(&inputFile, inPipePtr) == 0) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't create input pipe for command: %s", Tcl_PosixError(interp))); goto error; } inputClose = 1; } else { /* * The input for the first process comes from stdin. */ |
︙ | ︙ | |||
777 778 779 780 781 782 783 | if (outPipePtr != NULL) { /* * Output from the last process in the pipeline is to go to a pipe * that can be read by the caller. */ if (TclpCreatePipe(outPipePtr, &outputFile) == 0) { | | | | | 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 | if (outPipePtr != NULL) { /* * Output from the last process in the pipeline is to go to a pipe * that can be read by the caller. */ if (TclpCreatePipe(outPipePtr, &outputFile) == 0) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't create output pipe for command: %s", Tcl_PosixError(interp))); goto error; } outputClose = 1; } else { /* * The output for the last process goes to stdout. */ |
︙ | ︙ | |||
817 818 819 820 821 822 823 | * cause the pipeline to deadlock: we'd be waiting for processes * to complete before reading stderr, and processes couldn't * complete because stderr was backed up. */ errorFile = TclpCreateTempFile(NULL); if (errorFile == NULL) { | | | | | 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 | * cause the pipeline to deadlock: we'd be waiting for processes * to complete before reading stderr, and processes couldn't * complete because stderr was backed up. */ errorFile = TclpCreateTempFile(NULL); if (errorFile == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't create error file for command: %s", Tcl_PosixError(interp))); goto error; } *errFilePtr = errorFile; } else { /* * Errors from the pipeline go to stderr. */ |
︙ | ︙ | |||
890 891 892 893 894 895 896 | */ if (lastArg == argc) { curOutFile = outputFile; } else { argv[lastArg] = NULL; if (TclpCreatePipe(&pipeIn, &curOutFile) == 0) { | | | | 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 | */ if (lastArg == argc) { curOutFile = outputFile; } else { argv[lastArg] = NULL; if (TclpCreatePipe(&pipeIn, &curOutFile) == 0) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't create pipe: %s", Tcl_PosixError(interp))); goto error; } } if (joinThisError != 0) { curErrFile = curOutFile; } else { |
︙ | ︙ | |||
1070 1071 1072 1073 1074 1075 1076 | /* * Verify that the pipes that were created satisfy the readable/writable * constraints. */ if (flags & TCL_ENFORCE_MODE) { if ((flags & TCL_STDOUT) && (outPipe == NULL)) { | > | | > | | > | < | 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 | /* * Verify that the pipes that were created satisfy the readable/writable * constraints. */ if (flags & TCL_ENFORCE_MODE) { if ((flags & TCL_STDOUT) && (outPipe == NULL)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "can't read output from command:" " standard output was redirected", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "BADREDIRECT", NULL); goto error; } if ((flags & TCL_STDIN) && (inPipe == NULL)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "can't write input to command:" " standard input was redirected", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "BADREDIRECT", NULL); goto error; } } channel = TclpCreateCommandChannel(outPipe, inPipe, errFile, numPids, pidPtr); if (channel == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "pipe for command could not be created", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "NOPIPE", NULL); goto error; } return channel; error: if (numPids > 0) { |
︙ | ︙ |
Changes to generic/tclPkg.c.
︙ | ︙ | |||
150 151 152 153 154 155 156 | if (res == 0) { if (clientData != NULL) { pkgPtr->clientData = clientData; } return TCL_OK; } | > | | | 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 | if (res == 0) { if (clientData != NULL) { pkgPtr->clientData = clientData; } return TCL_OK; } Tcl_SetObjResult(interp, Tcl_ObjPrintf( "conflicting versions provided for package \"%s\": %s, then %s", name, pkgPtr->version, version)); Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT", NULL); return TCL_ERROR; } /* *---------------------------------------------------------------------- * |
︙ | ︙ | |||
280 281 282 283 284 285 286 | * message. That's the only flaw corrected; other problems with * initialization of the Tcl library are not remedied, so be very * careful about adding any other calls here without checking how they * behave when initialization is incomplete. */ tclEmptyStringRep = &tclEmptyString; | | | | | 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 | * message. That's the only flaw corrected; other problems with * initialization of the Tcl library are not remedied, so be very * careful about adding any other calls here without checking how they * behave when initialization is incomplete. */ tclEmptyStringRep = &tclEmptyString; Tcl_SetObjResult(interp, Tcl_ObjPrintf( "Cannot load package \"%s\" in standalone executable:" " This package is not compiled with stub support", name)); Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNSTUBBED", NULL); return NULL; } /* * Translate between old and new API, and defer to the new function. */ |
︙ | ︙ | |||
370 371 372 373 374 375 376 | /* * Check whether we're already attempting to load some version of this * package (circular dependency detection). */ if (pkgPtr->clientData != NULL) { | > | | | | 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 | /* * Check whether we're already attempting to load some version of this * package (circular dependency detection). */ if (pkgPtr->clientData != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "circular package dependency:" " attempt to provide %s %s requires %s", name, (char *) pkgPtr->clientData, name)); AddRequirementsToResult(interp, reqc, reqv); Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "CIRCULARITY", NULL); return NULL; } /* * The package isn't yet present. Search the list of available |
︙ | ︙ | |||
490 491 492 493 494 495 496 | Tcl_Release(script); pkgPtr = FindPackage(interp, name); if (code == TCL_OK) { Tcl_ResetResult(interp); if (pkgPtr->version == NULL) { code = TCL_ERROR; | > | < | | | | > | | < | | | | | 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 | Tcl_Release(script); pkgPtr = FindPackage(interp, name); if (code == TCL_OK) { Tcl_ResetResult(interp); if (pkgPtr->version == NULL) { code = TCL_ERROR; Tcl_SetObjResult(interp, Tcl_ObjPrintf( "attempt to provide package %s %s failed:" " no version of package %s provided", name, versionToProvide, name)); Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNPROVIDED", NULL); } else { char *pvi, *vi; if (CheckVersionAndConvert(interp, pkgPtr->version, &pvi, NULL) != TCL_OK) { code = TCL_ERROR; } else if (CheckVersionAndConvert(interp, versionToProvide, &vi, NULL) != TCL_OK) { ckfree(pvi); code = TCL_ERROR; } else { int res = CompareVersions(pvi, vi, NULL); ckfree(pvi); ckfree(vi); if (res != 0) { code = TCL_ERROR; Tcl_SetObjResult(interp, Tcl_ObjPrintf( "attempt to provide package %s %s failed:" " package %s %s provided instead", name, versionToProvide, name, pkgPtr->version)); Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "WRONGPROVIDE", NULL); } } } } else if (code != TCL_ERROR) { Tcl_Obj *codePtr = Tcl_NewIntObj(code); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "attempt to provide package %s %s failed:" " bad return code: %s", name, versionToProvide, TclGetString(codePtr))); Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL); TclDecrRefCount(codePtr); code = TCL_ERROR; } if (code == TCL_ERROR) { Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( |
︙ | ︙ | |||
587 588 589 590 591 592 593 | AddRequirementsToDString(&command, reqc, reqv); code = Tcl_EvalEx(interp, Tcl_DStringValue(&command), Tcl_DStringLength(&command), TCL_EVAL_GLOBAL); Tcl_DStringFree(&command); if ((code != TCL_OK) && (code != TCL_ERROR)) { | < < | | < < > | > | | | 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 | AddRequirementsToDString(&command, reqc, reqv); code = Tcl_EvalEx(interp, Tcl_DStringValue(&command), Tcl_DStringLength(&command), TCL_EVAL_GLOBAL); Tcl_DStringFree(&command); if ((code != TCL_OK) && (code != TCL_ERROR)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad return code: %d", code)); Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL); code = TCL_ERROR; } if (code == TCL_ERROR) { Tcl_AddErrorInfo(interp, "\n (\"package unknown\" script)"); return NULL; } Tcl_ResetResult(interp); } } if (pkgPtr->version == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't find package %s", name)); Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNFOUND", NULL); AddRequirementsToResult(interp, reqc, reqv); return NULL; } /* * At this point we know that the package is present. Make sure that the * provided version meets the current requirements. */ if (reqc != 0) { CheckVersionAndConvert(interp, pkgPtr->version, &pkgVersionI, NULL); satisfies = SomeRequirementSatisfied(pkgVersionI, reqc, reqv); ckfree(pkgVersionI); if (!satisfies) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "version conflict for package \"%s\": have %s, need", name, pkgPtr->version)); Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT", NULL); AddRequirementsToResult(interp, reqc, reqv); return NULL; } } |
︙ | ︙ | |||
717 718 719 720 721 722 723 | NULL); } return foundVersion; } } if (version != NULL) { | | | > | | 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 | NULL); } return foundVersion; } } if (version != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "package %s %s is not present", name, version)); } else { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "package %s is not present", name)); } Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PACKAGE", name, NULL); return NULL; } /* *---------------------------------------------------------------------- |
︙ | ︙ | |||
1350 1351 1352 1353 1354 1355 1356 | *stable = !hasunstable; } return TCL_OK; } error: ckfree(ibuf); | > | < | 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 | *stable = !hasunstable; } return TCL_OK; } error: ckfree(ibuf); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "expected version number but got \"%s\"", string)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "VERSION", NULL); return TCL_ERROR; } /* *---------------------------------------------------------------------- * |
︙ | ︙ | |||
1613 1614 1615 1616 1617 1618 1619 | } if (strchr(dash+1, '-') != NULL) { /* * More dashes found after the first. This is wrong. */ | > | < | 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 | } if (strchr(dash+1, '-') != NULL) { /* * More dashes found after the first. This is wrong. */ Tcl_SetObjResult(interp, Tcl_ObjPrintf( "expected versionMin-versionMax but got \"%s\"", string)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "VERSIONRANGE", NULL); return TCL_ERROR; } /* * Exactly one dash is present. Copy the string, split at the location of * dash and check that both parts are versions. Note that the max part can |
︙ | ︙ | |||
1666 1667 1668 1669 1670 1671 1672 | AddRequirementsToResult( Tcl_Interp *interp, int reqc, /* Requirements constraining the desired * version. */ Tcl_Obj *const reqv[]) /* 0 means to use the latest version * available. */ { | | | | < | | | | | | < | 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 | AddRequirementsToResult( Tcl_Interp *interp, int reqc, /* Requirements constraining the desired * version. */ Tcl_Obj *const reqv[]) /* 0 means to use the latest version * available. */ { Tcl_Obj *result = Tcl_GetObjResult(interp); int i, length; for (i = 0; i < reqc; i++) { const char *v = Tcl_GetStringFromObj(reqv[i], &length); if ((length & 0x1) && (v[length/2] == '-') && (strncmp(v, v+((length+1)/2), length/2) == 0)) { Tcl_AppendPrintfToObj(result, " exactly %s", v+((length+1)/2)); } else { Tcl_AppendPrintfToObj(result, " %s", v); } } } /* *---------------------------------------------------------------------- * |
︙ | ︙ | |||
1707 1708 1709 1710 1711 1712 1713 | AddRequirementsToDString( Tcl_DString *dsPtr, int reqc, /* Requirements constraining the desired * version. */ Tcl_Obj *const reqv[]) /* 0 means to use the latest version * available. */ { | < | > | 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 | AddRequirementsToDString( Tcl_DString *dsPtr, int reqc, /* Requirements constraining the desired * version. */ Tcl_Obj *const reqv[]) /* 0 means to use the latest version * available. */ { int i; if (reqc > 0) { for (i = 0; i < reqc; i++) { TclDStringAppendLiteral(dsPtr, " "); TclDStringAppendObj(dsPtr, reqv[i]); } } else { TclDStringAppendLiteral(dsPtr, " 0-"); } |
︙ | ︙ |
Changes to generic/tclProc.c.
︙ | ︙ | |||
148 149 150 151 152 153 154 | */ fullName = TclGetString(objv[1]); TclGetNamespaceForQualName(interp, fullName, NULL, 0, &nsPtr, &altNsPtr, &cxtNsPtr, &procName); if (nsPtr == NULL) { | | | > | | > > | | < | 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 | */ fullName = TclGetString(objv[1]); TclGetNamespaceForQualName(interp, fullName, NULL, 0, &nsPtr, &altNsPtr, &cxtNsPtr, &procName); if (nsPtr == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't create procedure \"%s\": unknown namespace", fullName)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL); return TCL_ERROR; } if (procName == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't create procedure \"%s\": bad procedure name", fullName)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL); return TCL_ERROR; } if ((nsPtr != iPtr->globalNsPtr) && (procName != NULL) && (procName[0] == ':')) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't create procedure \"%s\" in non-global namespace with" " name starting with \":\"", procName)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL); return TCL_ERROR; } /* * Create the data structure to represent the procedure. */ |
︙ | ︙ | |||
514 515 516 517 518 519 520 | result = Tcl_SplitList(interp, argArray[i], &fieldCount, &fieldValues); if (result != TCL_OK) { goto procError; } if (fieldCount > 2) { ckfree(fieldValues); | | | | > | | 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 | result = Tcl_SplitList(interp, argArray[i], &fieldCount, &fieldValues); if (result != TCL_OK) { goto procError; } if (fieldCount > 2) { ckfree(fieldValues); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "too many fields in argument specifier \"%s\"", argArray[i])); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "FORMALARGUMENTFORMAT", NULL); goto procError; } if ((fieldCount == 0) || (*fieldValues[0] == 0)) { ckfree(fieldValues); Tcl_SetObjResult(interp, Tcl_NewStringObj( "argument with no name", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "FORMALARGUMENTFORMAT", NULL); goto procError; } nameLength = strlen(fieldValues[0]); if (fieldCount == 2) { |
︙ | ︙ | |||
549 550 551 552 553 554 555 | if (*p == '(') { const char *q = p; do { q++; } while (*q != '\0'); q--; if (*q == ')') { /* We have an array element. */ | > | | > | | | 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 | if (*p == '(') { const char *q = p; do { q++; } while (*q != '\0'); q--; if (*q == ')') { /* We have an array element. */ Tcl_SetObjResult(interp, Tcl_ObjPrintf( "formal parameter \"%s\" is an array element", fieldValues[0])); ckfree(fieldValues); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "FORMALARGUMENTFORMAT", NULL); goto procError; } } else if ((*p == ':') && (*(p+1) == ':')) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "formal parameter \"%s\" is not a simple name", fieldValues[0])); ckfree(fieldValues); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "FORMALARGUMENTFORMAT", NULL); goto procError; } p++; } |
︙ | ︙ | |||
763 764 765 766 767 768 769 | goto levelError; } *framePtrPtr = framePtr; return result; levelError: | | < | 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 | goto levelError; } *framePtrPtr = framePtr; return result; levelError: Tcl_SetObjResult(interp, Tcl_ObjPrintf("bad level \"%s\"", name)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "STACKLEVEL", NULL); return -1; } /* *---------------------------------------------------------------------- * |
︙ | ︙ | |||
896 897 898 899 900 901 902 | if (framePtr == NULL) { goto levelError; } *framePtrPtr = framePtr; return result; levelError: | | < | 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 | if (framePtr == NULL) { goto levelError; } *framePtrPtr = framePtr; return result; levelError: Tcl_SetObjResult(interp, Tcl_ObjPrintf("bad level \"%s\"", name)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "STACKLEVEL", NULL); return -1; } /* *---------------------------------------------------------------------- * |
︙ | ︙ | |||
1875 1876 1877 1878 1879 1880 1881 | case TCL_CONTINUE: case TCL_BREAK: /* * It's an error to get to this point from a 'break' or 'continue', so * transform to an error now. */ | | | | < | 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 | case TCL_CONTINUE: case TCL_BREAK: /* * It's an error to get to this point from a 'break' or 'continue', so * transform to an error now. */ Tcl_SetObjResult(interp, Tcl_ObjPrintf( "invoked \"%s\" outside of a loop", ((result == TCL_BREAK) ? "break" : "continue"))); Tcl_SetErrorCode(interp, "TCL", "RESULT", "UNEXPECTED", NULL); result = TCL_ERROR; /* * Fall through to the TCL_ERROR handling code. */ |
︙ | ︙ | |||
1995 1996 1997 1998 1999 2000 2001 | && (codePtr->nsPtr == nsPtr) && (codePtr->nsEpoch == nsPtr->resolverEpoch)) { return TCL_OK; } if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) { if ((Interp *) *codePtr->interpHandle != iPtr) { | | | | 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 | && (codePtr->nsPtr == nsPtr) && (codePtr->nsEpoch == nsPtr->resolverEpoch)) { return TCL_OK; } if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) { if ((Interp *) *codePtr->interpHandle != iPtr) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "a precompiled script jumped interps", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "CROSSINTERPBYTECODE", NULL); return TCL_ERROR; } codePtr->compileEpoch = iPtr->compileEpoch; codePtr->nsPtr = nsPtr; } else { |
︙ | ︙ | |||
2928 2929 2930 2931 2932 2933 2934 | if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "procName"); return TCL_ERROR; } procPtr = TclFindProc((Interp *) interp, TclGetString(objv[2])); if (procPtr == NULL) { | | | | 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 | if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "procName"); return TCL_ERROR; } procPtr = TclFindProc((Interp *) interp, TclGetString(objv[2])); if (procPtr == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "\"%s\" isn't a procedure", TclGetString(objv[2]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROC", TclGetString(objv[2]), NULL); return TCL_ERROR; } /* * Compile (if uncompiled) and disassemble a procedure. |
︙ | ︙ | |||
2978 2979 2980 2981 2982 2983 2984 | */ oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]); if (oPtr == NULL) { return TCL_ERROR; } if (oPtr->classPtr == NULL) { | | | | 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 | */ oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]); if (oPtr == NULL) { return TCL_ERROR; } if (oPtr->classPtr == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "\"%s\" is not a class", TclGetString(objv[2]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS", TclGetString(objv[2]), NULL); return TCL_ERROR; } hPtr = Tcl_FindHashEntry(&oPtr->classPtr->classMethods, (char *) objv[3]); goto methodBody; |
︙ | ︙ | |||
3013 3014 3015 3016 3017 3018 3019 | /* * Compile (if necessary) and disassemble a method body. */ methodBody: if (hPtr == NULL) { unknownMethod: | | | | | | 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 | /* * Compile (if necessary) and disassemble a method body. */ methodBody: if (hPtr == NULL) { unknownMethod: Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unknown method \"%s\"", TclGetString(objv[3]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", TclGetString(objv[3]), NULL); return TCL_ERROR; } procPtr = TclOOGetProcFromMethod(Tcl_GetHashValue(hPtr)); if (procPtr == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "body not available for this kind of method", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", "METHODTYPE", NULL); return TCL_ERROR; } if (procPtr->bodyPtr->typePtr != &tclByteCodeType) { Command cmd; |
︙ | ︙ | |||
3057 3058 3059 3060 3061 3062 3063 | /* * Do the actual disassembly. */ if (((ByteCode *) codeObjPtr->internalRep.otherValuePtr)->flags & TCL_BYTECODE_PRECOMPILED) { | > | | 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 | /* * Do the actual disassembly. */ if (((ByteCode *) codeObjPtr->internalRep.otherValuePtr)->flags & TCL_BYTECODE_PRECOMPILED) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "may not disassemble prebuilt bytecode", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", "BYTECODE", NULL); return TCL_ERROR; } Tcl_SetObjResult(interp, TclDisassembleByteCodeObj(codeObjPtr)); return TCL_OK; } |
︙ | ︙ |
Changes to generic/tclZlib.c.
︙ | ︙ | |||
1892 1893 1894 1895 1896 1897 1898 | format = TCL_ZLIB_FORMAT_GZIP; break; case FMT_GUNZIP: mode = TCL_ZLIB_STREAM_INFLATE; format = TCL_ZLIB_FORMAT_GZIP; break; default: | | | | | | | | | | | | | 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 | format = TCL_ZLIB_FORMAT_GZIP; break; case FMT_GUNZIP: mode = TCL_ZLIB_STREAM_INFLATE; format = TCL_ZLIB_FORMAT_GZIP; break; default: Tcl_SetObjResult(interp, Tcl_NewStringObj("impossible!", -1)); return TCL_ERROR; } if (TclGetChannelFromObj(interp, objv[3], &chan, &chanMode, 0) != TCL_OK) { return TCL_ERROR; } /* * Sanity checks. */ if (mode == TCL_ZLIB_STREAM_DEFLATE && !(chanMode & TCL_WRITABLE)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "compression may only be applied to writable channels", -1)); Tcl_SetErrorCode(interp, "TCL", "ZIP", "UNWRITABLE", NULL); return TCL_ERROR; } if (mode == TCL_ZLIB_STREAM_INFLATE && !(chanMode & TCL_READABLE)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "decompression may only be applied to readable channels", -1)); Tcl_SetErrorCode(interp, "TCL", "ZIP", "UNREADABLE", NULL); return TCL_ERROR; } /* * Parse options. */ level = Z_DEFAULT_COMPRESSION; for (i=4 ; i<objc ; i++) { if (Tcl_GetIndexFromObj(interp, objv[i], pushOptions, "option", 0, &option) != TCL_OK) { return TCL_ERROR; } switch ((enum pushOptions) option) { case poHeader: if (++i > objc-1) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "value missing for -header option", -1)); Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL); return TCL_ERROR; } headerObj = objv[i]; if (Tcl_DictObjSize(interp, headerObj, &dummy) != TCL_OK) { Tcl_AddErrorInfo(interp, "\n (in -header option)"); return TCL_ERROR; } break; case poLevel: if (++i > objc-1) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "value missing for -level option", -1)); Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL); return TCL_ERROR; } if (Tcl_GetIntFromObj(interp, objv[i], (int *) &level) != TCL_OK) { Tcl_AddErrorInfo(interp, "\n (in -level option)"); return TCL_ERROR; } if (level < 0 || level > 9) { extraInfoStr = "\n (in -level option)"; goto badLevel; } break; case poLimit: if (++i > objc-1) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "value missing for -limit option", -1)); Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL); return TCL_ERROR; } if (Tcl_GetIntFromObj(interp, objv[i], (int *) &limit) != TCL_OK) { Tcl_AddErrorInfo(interp, "\n (in -limit option)"); return TCL_ERROR; |
︙ | ︙ | |||
1992 1993 1994 1995 1996 1997 1998 | return TCL_OK; } }; return TCL_ERROR; badLevel: | | > | | 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 | return TCL_OK; } }; return TCL_ERROR; badLevel: Tcl_SetObjResult(interp, Tcl_NewStringObj("level must be 0 to 9", -1)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMPRESSIONLEVEL", NULL); if (extraInfoStr) { Tcl_AddErrorInfo(interp, extraInfoStr); } return TCL_ERROR; badBuffer: Tcl_SetObjResult(interp, Tcl_NewStringObj( "buffer size must be 32 to 65536", -1)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "BUFFERSIZE", NULL); return TCL_ERROR; } /* *---------------------------------------------------------------------- * |
︙ | ︙ | |||
2082 2083 2084 2085 2086 2087 2088 | flush = -2; } else { flush = Z_FINISH; } break; case ao_buffer: /* -buffer */ if (i == objc-2) { | > | | < | | > | | | 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 | flush = -2; } else { flush = Z_FINISH; } break; case ao_buffer: /* -buffer */ if (i == objc-2) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "\"-buffer\" option must be followed by integer" " decompression buffersize", -1)); Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL); return TCL_ERROR; } if (Tcl_GetIntFromObj(interp, objv[i+1], &buffersize) != TCL_OK) { return TCL_ERROR; } if (buffersize < 1 || buffersize > 65536) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "buffer size must be 32 to 65536", -1)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "BUFFERSIZE", NULL); return TCL_ERROR; } } if (flush == -2) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "\"-flush\", \"-fullflush\" and \"-finalize\" options" " are mutually exclusive", -1)); Tcl_SetErrorCode(interp, "TCL", "ZIP", "EXCLUSIVE", NULL); return TCL_ERROR; } } if (flush == -1) { flush = 0; } |
︙ | ︙ | |||
2154 2155 2156 2157 2158 2159 2160 | if (flush > -1) { flush = -2; } else { flush = Z_FINISH; } break; case ao_buffer: | | | > | | | 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 | if (flush > -1) { flush = -2; } else { flush = Z_FINISH; } break; case ao_buffer: Tcl_SetObjResult(interp, Tcl_NewStringObj( "\"-buffer\" option not supported here", -1)); return TCL_ERROR; } if (flush == -2) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "\"-flush\", \"-fullflush\" and \"-finalize\" options" " are mutually exclusive", -1)); Tcl_SetErrorCode(interp, "TCL", "ZIP", "EXCLUSIVE", NULL); return TCL_ERROR; } } if (flush == -1) { flush = 0; } |
︙ | ︙ | |||
2310 2311 2312 2313 2314 2315 2316 | if (Tcl_WriteRaw(cd->parent, cd->outBuffer, cd->outAllocated - cd->outStream.avail_out) < 0) { /* TODO: is this the right way to do errors on close? * Note: when close is called from FinalizeIOSubsystem * then interp may be NULL */ if (!TclInThreadExit()) { if (interp) { | | | | | 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 | if (Tcl_WriteRaw(cd->parent, cd->outBuffer, cd->outAllocated - cd->outStream.avail_out) < 0) { /* TODO: is this the right way to do errors on close? * Note: when close is called from FinalizeIOSubsystem * then interp may be NULL */ if (!TclInThreadExit()) { if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "error while finalizing file: %s", Tcl_PosixError(interp))); } } result = TCL_ERROR; break; } } } while (e != Z_STREAM_END); |
︙ | ︙ | |||
2607 2608 2609 2610 2611 2612 2613 | return TCL_ERROR; } else if (cd->outStream.avail_out == 0) { break; } if (Tcl_WriteRaw(cd->parent, cd->outBuffer, cd->outStream.next_out - (Bytef *) cd->outBuffer) < 0) { | > | | | 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 | return TCL_ERROR; } else if (cd->outStream.avail_out == 0) { break; } if (Tcl_WriteRaw(cd->parent, cd->outBuffer, cd->outStream.next_out - (Bytef *) cd->outBuffer) < 0) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "problem flushing channel: %s", Tcl_PosixError(interp))); return TCL_ERROR; } } return TCL_OK; } if (setOptionProc == NULL) { |
︙ | ︙ |
Changes to tests/format.test.
︙ | ︙ | |||
545 546 547 548 549 550 551 | } {1 1 1 1} test format-18.2 {do not demote existing numeric values} {wideBiggerThanInt} { set a [expr {0xaaaaaaaaaa + 1}] set b 0xaaaaaaaaab list [format %08x $a] [expr {$a == $b}] } {aaaaaaab 1} | < | < < | | 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 | } {1 1 1 1} test format-18.2 {do not demote existing numeric values} {wideBiggerThanInt} { set a [expr {0xaaaaaaaaaa + 1}] set b 0xaaaaaaaaab list [format %08x $a] [expr {$a == $b}] } {aaaaaaab 1} test format-19.1 {regression test - tcl-core message by Brian Griffin on 26 0ctober 2004} -body { set x 0x8fedc654 list [expr { ~ $x }] [format %08x [expr { ~$x }]] } -match regexp -result {-2414724693 f*701239ab} test format-19.2 {Bug 1867855} { format %llx 0 } 0 test format-19.3 {Bug 2830354} { string length [format %340f 0] } 340 # Note that this test may fail in future versions test format-20.1 {Bug 2932421: plain %s caused intrep change of args} -body { set x [dict create a b c d] format %s $x # After this, obj in $x should be a dict with a non-NULL bytes field tcl::unsupported::representation $x } -match glob -result {value is a dict with *, string representation "*"} # cleanup catch {unset a} catch {unset b} catch {unset c} catch {unset d} ::tcltest::cleanupTests return # Local Variables: # mode: tcl # End: |