Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Overview
Comment: | More generation of errorCode information, notably when lists are mis-parsed. |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors | descendants | both | trunk |
Files: | files | file ages | folders |
SHA1: |
999804376cc4de0b5b25215372acd1bc |
User & Date: | dkf 2011-03-29 15:06:26 |
Context
2011-03-31
| ||
10:04 | TclClockOldscanObjCmd: More generation of errorCode information. check-in: 25eb27727e user: dkf tags: trunk | |
2011-03-29
| ||
15:06 | More generation of errorCode information, notably when lists are mis-parsed. check-in: 999804376c user: dkf tags: trunk | |
2011-03-28
| ||
12:15 | Corrected odd comment check-in: 748898a892 user: dkf tags: trunk | |
Changes
Changes to ChangeLog.
1 2 3 4 5 6 7 8 | 2011-03-28 Donal K. Fellows <[email protected]> * generic/tclCmdMZ.c (Tcl_RegexpObjCmd, Tcl_RegsubObjCmd): Use the error messages generated by the variable management code rather than creating our own. 2011-03-27 Miguel Sofer <[email protected]> | > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 | 2011-03-28 Donal K. Fellows <[email protected]> * generic/tclCmdMZ.c, generic/tclConfig.c, generic/tclUtil.c: More generation of errorCode information, notably when lists are mis-parsed. * generic/tclCmdMZ.c (Tcl_RegexpObjCmd, Tcl_RegsubObjCmd): Use the error messages generated by the variable management code rather than creating our own. 2011-03-27 Miguel Sofer <[email protected]> |
︙ | ︙ |
Changes to generic/tclCmdMZ.c.
︙ | ︙ | |||
1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 | if ((length2 > 1) && strncmp(string, "-nocase", (size_t) length2) == 0) { nocase = 1; } else { Tcl_AppendResult(interp, "bad option \"", string, "\": must be -nocase", NULL); return TCL_ERROR; } } /* * This test is tricky, but has to be that way or you get other strange * inconsistencies (see test string-10.20 for illustration why!) | > > | 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 | if ((length2 > 1) && strncmp(string, "-nocase", (size_t) length2) == 0) { nocase = 1; } else { Tcl_AppendResult(interp, "bad option \"", string, "\": must be -nocase", NULL); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option", string, NULL); return TCL_ERROR; } } /* * This test is tricky, but has to be that way or you get other strange * inconsistencies (see test string-10.20 for illustration why!) |
︙ | ︙ | |||
1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 | } else if (mapElemc & 1) { /* * The charMap must be an even number of key/value items. */ Tcl_SetObjResult(interp, Tcl_NewStringObj("char map list unbalanced", -1)); return TCL_ERROR; } } /* * Take a copy of the source string object if it is the same as the map * string to cut out nasty sharing crashes. [Bug 1018562] | > > | 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 | } else if (mapElemc & 1) { /* * The charMap must be an even number of key/value items. */ Tcl_SetObjResult(interp, Tcl_NewStringObj("char map list unbalanced", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "MAP", "UNBALANCED", NULL); return TCL_ERROR; } } /* * Take a copy of the source string object if it is the same as the map * string to cut out nasty sharing crashes. [Bug 1018562] |
︙ | ︙ | |||
2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 | if ((length > 1) && strncmp(string, "-nocase", (size_t) length) == 0) { nocase = TCL_MATCH_NOCASE; } else { Tcl_AppendResult(interp, "bad option \"", string, "\": must be -nocase", NULL); return TCL_ERROR; } } Tcl_SetObjResult(interp, Tcl_NewBooleanObj( TclStringMatchObj(objv[objc-1], objv[objc-2], nocase))); return TCL_OK; } | > > | 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 | if ((length > 1) && strncmp(string, "-nocase", (size_t) length) == 0) { nocase = TCL_MATCH_NOCASE; } else { Tcl_AppendResult(interp, "bad option \"", string, "\": must be -nocase", NULL); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option", string, NULL); return TCL_ERROR; } } Tcl_SetObjResult(interp, Tcl_NewBooleanObj( TclStringMatchObj(objv[objc-1], objv[objc-2], nocase))); return TCL_OK; } |
︙ | ︙ | |||
2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 | * We need to keep 2 <= length2 <= INT_MAX. */ if (count > INT_MAX/length1) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "result exceeds max size for a Tcl value (%d bytes)", INT_MAX)); return TCL_ERROR; } length2 = length1 * count; /* * Include space for the NUL. */ string2 = attemptckalloc((unsigned) length2 + 1); if (string2 == NULL) { /* * Alloc failed. Note that in this case we try to do an error message * since this is a case that's most likely when the alloc is large and * that's easy to do with this API. Note that if we fail allocating a * short string, this will likely keel over too (and fatally). */ Tcl_SetObjResult(interp, Tcl_ObjPrintf( "string size overflow, out of memory allocating %u bytes", length2 + 1)); return TCL_ERROR; } for (index = 0; index < count; index++) { memcpy(string2 + (length1 * index), string1, (size_t) length1); } string2[length2] = '\0'; | > > | 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 | * We need to keep 2 <= length2 <= INT_MAX. */ if (count > INT_MAX/length1) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "result exceeds max size for a Tcl value (%d bytes)", INT_MAX)); Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); return TCL_ERROR; } length2 = length1 * count; /* * Include space for the NUL. */ string2 = attemptckalloc((unsigned) length2 + 1); if (string2 == NULL) { /* * Alloc failed. Note that in this case we try to do an error message * since this is a case that's most likely when the alloc is large and * that's easy to do with this API. Note that if we fail allocating a * short string, this will likely keel over too (and fatally). */ Tcl_SetObjResult(interp, Tcl_ObjPrintf( "string size overflow, out of memory allocating %u bytes", length2 + 1)); Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); return TCL_ERROR; } for (index = 0; index < count; index++) { memcpy(string2 + (length1 * index), string1, (size_t) length1); } string2[length2] = '\0'; |
︙ | ︙ | |||
2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 | i++; if (TclGetIntFromObj(interp, objv[i], &reqlength) != TCL_OK) { return TCL_ERROR; } } else { Tcl_AppendResult(interp, "bad option \"", string2, "\": must be -nocase or -length", NULL); return TCL_ERROR; } } /* * From now on, we only access the two objects at the end of the argument * array. | > > | 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 | i++; if (TclGetIntFromObj(interp, objv[i], &reqlength) != TCL_OK) { return TCL_ERROR; } } else { Tcl_AppendResult(interp, "bad option \"", string2, "\": must be -nocase or -length", NULL); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option", string2, NULL); return TCL_ERROR; } } /* * From now on, we only access the two objects at the end of the argument * array. |
︙ | ︙ | |||
2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 | i++; if (TclGetIntFromObj(interp, objv[i], &reqlength) != TCL_OK) { return TCL_ERROR; } } else { Tcl_AppendResult(interp, "bad option \"", string2, "\": must be -nocase or -length", NULL); return TCL_ERROR; } } /* * From now on, we only access the two objects at the end of the argument * array. | > > | 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 | i++; if (TclGetIntFromObj(interp, objv[i], &reqlength) != TCL_OK) { return TCL_ERROR; } } else { Tcl_AppendResult(interp, "bad option \"", string2, "\": must be -nocase or -length", NULL); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option", string2, NULL); return TCL_ERROR; } } /* * From now on, we only access the two objects at the end of the argument * array. |
︙ | ︙ | |||
3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 | /* * Mode already set via -exact, -glob, or -regexp. */ Tcl_AppendResult(interp, "bad option \"", TclGetString(objv[i]), "\": ", options[mode], " option already found", NULL); return TCL_ERROR; } foundmode = 1; mode = index; break; /* * Check for TIP#75 options specifying the variables to write * regexp information into. */ case OPT_INDEXV: i++; if (i >= objc-2) { Tcl_AppendResult(interp, "missing variable name argument to ", "-indexvar", " option", NULL); return TCL_ERROR; } indexVarObj = objv[i]; numMatchesSaved = -1; break; case OPT_MATCHV: i++; if (i >= objc-2) { Tcl_AppendResult(interp, "missing variable name argument to ", "-matchvar", " option", NULL); return TCL_ERROR; } matchVarObj = objv[i]; numMatchesSaved = -1; break; } } finishedOptions: if (objc - i < 2) { Tcl_WrongNumArgs(interp, 1, objv, "?-switch ...? string ?pattern body ...? ?default body?"); return TCL_ERROR; } if (indexVarObj != NULL && mode != OPT_REGEXP) { Tcl_AppendResult(interp, "-indexvar option requires -regexp option", NULL); return TCL_ERROR; } if (matchVarObj != NULL && mode != OPT_REGEXP) { Tcl_AppendResult(interp, "-matchvar option requires -regexp option", NULL); return TCL_ERROR; } stringObj = objv[i]; objc -= i + 1; objv += i + 1; bidx = i + 1; /* First after the match string. */ | > > > > > > > > > > | 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 3631 3632 3633 3634 3635 3636 3637 | /* * Mode already set via -exact, -glob, or -regexp. */ Tcl_AppendResult(interp, "bad option \"", TclGetString(objv[i]), "\": ", options[mode], " option already found", NULL); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", "DOUBLEOPT", NULL); return TCL_ERROR; } foundmode = 1; mode = index; break; /* * Check for TIP#75 options specifying the variables to write * regexp information into. */ case OPT_INDEXV: i++; if (i >= objc-2) { Tcl_AppendResult(interp, "missing variable name argument to ", "-indexvar", " option", NULL); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", "NOVAR", NULL); return TCL_ERROR; } indexVarObj = objv[i]; numMatchesSaved = -1; break; case OPT_MATCHV: i++; if (i >= objc-2) { Tcl_AppendResult(interp, "missing variable name argument to ", "-matchvar", " option", NULL); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", "NOVAR", NULL); return TCL_ERROR; } matchVarObj = objv[i]; numMatchesSaved = -1; break; } } finishedOptions: if (objc - i < 2) { Tcl_WrongNumArgs(interp, 1, objv, "?-switch ...? string ?pattern body ...? ?default body?"); return TCL_ERROR; } if (indexVarObj != NULL && mode != OPT_REGEXP) { Tcl_AppendResult(interp, "-indexvar option requires -regexp option", NULL); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", "MODERESTRICTION", NULL); return TCL_ERROR; } if (matchVarObj != NULL && mode != OPT_REGEXP) { Tcl_AppendResult(interp, "-matchvar option requires -regexp option", NULL); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", "MODERESTRICTION", NULL); return TCL_ERROR; } stringObj = objv[i]; objc -= i + 1; objv += i + 1; bidx = i + 1; /* First after the match string. */ |
︙ | ︙ | |||
3649 3650 3651 3652 3653 3654 3655 3656 3657 3658 3659 3660 3661 3662 3663 3664 3665 3666 3667 3668 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 | * Complain if there is an odd number of words in the list of patterns and * bodies. */ if (objc % 2) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "extra switch pattern with no body", NULL); /* * Check if this can be due to a badly placed comment in the switch * block. * * The following is an heuristic to detect the infamous "comment in * switch" error: just check if a pattern begins with '#'. */ if (splitObjs) { for (i=0 ; i<objc ; i+=2) { if (TclGetString(objv[i])[0] == '#') { Tcl_AppendResult(interp, ", this may be due to a " "comment incorrectly placed outside of a " "switch body - see the \"switch\" " "documentation", NULL); break; } } } return TCL_ERROR; } /* * Complain if the last body is a continuation. Note that this check * assumes that the list is non-empty! */ if (strcmp(TclGetString(objv[objc-1]), "-") == 0) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "no body specified for pattern \"", TclGetString(objv[objc-2]), "\"", NULL); return TCL_ERROR; } for (i = 0; i < objc; i += 2) { /* * See if the pattern matches the string. */ | > > > > > > | 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 | * Complain if there is an odd number of words in the list of patterns and * bodies. */ if (objc % 2) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "extra switch pattern with no body", NULL); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", "BADARM", NULL); /* * Check if this can be due to a badly placed comment in the switch * block. * * The following is an heuristic to detect the infamous "comment in * switch" error: just check if a pattern begins with '#'. */ if (splitObjs) { for (i=0 ; i<objc ; i+=2) { if (TclGetString(objv[i])[0] == '#') { Tcl_AppendResult(interp, ", this may be due to a " "comment incorrectly placed outside of a " "switch body - see the \"switch\" " "documentation", NULL); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", "BADARM", "COMMENT?", NULL); break; } } } return TCL_ERROR; } /* * Complain if the last body is a continuation. Note that this check * assumes that the list is non-empty! */ if (strcmp(TclGetString(objv[objc-1]), "-") == 0) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "no body specified for pattern \"", TclGetString(objv[objc-2]), "\"", NULL); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", "BADARM", "FALLTHROUGH", NULL); return TCL_ERROR; } for (i = 0; i < objc; i += 2) { /* * See if the pattern matches the string. */ |
︙ | ︙ | |||
4002 4003 4004 4005 4006 4007 4008 4009 4010 4011 4012 4013 4014 4015 | * The type must be a list of at least length 1. */ if (Tcl_ListObjLength(interp, objv[1], &len) != TCL_OK) { return TCL_ERROR; } else if (len < 1) { Tcl_AppendResult(interp, "type must be non-empty list", NULL); return TCL_ERROR; } /* * Now prepare the result options dictionary. We use the list API as it is * slightly more convenient. */ | > > | 4030 4031 4032 4033 4034 4035 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 | * The type must be a list of at least length 1. */ if (Tcl_ListObjLength(interp, objv[1], &len) != TCL_OK) { return TCL_ERROR; } else if (len < 1) { Tcl_AppendResult(interp, "type must be non-empty list", NULL); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "THROW", "BADEXCEPTION", NULL); return TCL_ERROR; } /* * Now prepare the result options dictionary. We use the list API as it is * slightly more convenient. */ |
︙ | ︙ | |||
4185 4186 4187 4188 4189 4190 4191 4192 4193 4194 4195 4196 4197 4198 4199 4200 4201 4202 4203 4204 4205 4206 4207 4208 4209 4210 4211 4212 4213 4214 4215 4216 4217 4218 4219 4220 4221 4222 4223 4224 4225 4226 4227 4228 4229 4230 4231 4232 4233 4234 4235 4236 4237 4238 | return TCL_ERROR; } switch ((enum Handlers) type) { case TryFinally: /* finally script */ if (i < objc-2) { Tcl_AppendResult(interp, "finally clause must be last", NULL); Tcl_DecrRefCount(handlersObj); return TCL_ERROR; } else if (i == objc-1) { Tcl_AppendResult(interp, "wrong # args to finally clause: ", "must be \"", TclGetString(objv[0]), " ... finally script\"", NULL); Tcl_DecrRefCount(handlersObj); return TCL_ERROR; } finallyObj = objv[++i]; break; case TryOn: /* on code variableList script */ if (i > objc-4) { Tcl_AppendResult(interp, "wrong # args to on clause: ", "must be \"", TclGetString(objv[0]), " ... on code variableList script\"", NULL); Tcl_DecrRefCount(handlersObj); return TCL_ERROR; } if (TCL_ERROR == TclGetCompletionCodeFromObj(interp, objv[i+1], &code)) { Tcl_DecrRefCount(handlersObj); return TCL_ERROR; } info[2] = NULL; goto commonHandler; case TryTrap: /* trap pattern variableList script */ if (i > objc-4) { Tcl_AppendResult(interp, "wrong # args to trap clause: ", "must be \"... trap pattern variableList script\"", NULL); Tcl_DecrRefCount(handlersObj); return TCL_ERROR; } code = 1; if (Tcl_ListObjLength(NULL, objv[i+1], &dummy) != TCL_OK) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad prefix '%s': must be a list", Tcl_GetString(objv[i+1]))); Tcl_DecrRefCount(handlersObj); return TCL_ERROR; } info[2] = objv[i+1]; commonHandler: if (Tcl_ListObjLength(interp, objv[i+2], &dummy) != TCL_OK) { Tcl_DecrRefCount(handlersObj); | > > > > > > > > > > | 4215 4216 4217 4218 4219 4220 4221 4222 4223 4224 4225 4226 4227 4228 4229 4230 4231 4232 4233 4234 4235 4236 4237 4238 4239 4240 4241 4242 4243 4244 4245 4246 4247 4248 4249 4250 4251 4252 4253 4254 4255 4256 4257 4258 4259 4260 4261 4262 4263 4264 4265 4266 4267 4268 4269 4270 4271 4272 4273 4274 4275 4276 4277 4278 | return TCL_ERROR; } switch ((enum Handlers) type) { case TryFinally: /* finally script */ if (i < objc-2) { Tcl_AppendResult(interp, "finally clause must be last", NULL); Tcl_DecrRefCount(handlersObj); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "FINALLY", "NONTERMINAL", NULL); return TCL_ERROR; } else if (i == objc-1) { Tcl_AppendResult(interp, "wrong # args to finally clause: ", "must be \"", TclGetString(objv[0]), " ... finally script\"", NULL); Tcl_DecrRefCount(handlersObj); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "FINALLY", "ARGUMENT", NULL); return TCL_ERROR; } finallyObj = objv[++i]; break; case TryOn: /* on code variableList script */ if (i > objc-4) { Tcl_AppendResult(interp, "wrong # args to on clause: ", "must be \"", TclGetString(objv[0]), " ... on code variableList script\"", NULL); Tcl_DecrRefCount(handlersObj); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "ON", "ARGUMENT", NULL); return TCL_ERROR; } if (TCL_ERROR == TclGetCompletionCodeFromObj(interp, objv[i+1], &code)) { Tcl_DecrRefCount(handlersObj); return TCL_ERROR; } info[2] = NULL; goto commonHandler; case TryTrap: /* trap pattern variableList script */ if (i > objc-4) { Tcl_AppendResult(interp, "wrong # args to trap clause: ", "must be \"... trap pattern variableList script\"", NULL); Tcl_DecrRefCount(handlersObj); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "TRAP", "ARGUMENT", NULL); return TCL_ERROR; } code = 1; if (Tcl_ListObjLength(NULL, objv[i+1], &dummy) != TCL_OK) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad prefix '%s': must be a list", Tcl_GetString(objv[i+1]))); Tcl_DecrRefCount(handlersObj); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "TRAP", "EXNFORMAT", NULL); return TCL_ERROR; } info[2] = objv[i+1]; commonHandler: if (Tcl_ListObjLength(interp, objv[i+2], &dummy) != TCL_OK) { Tcl_DecrRefCount(handlersObj); |
︙ | ︙ | |||
4256 4257 4258 4259 4260 4261 4262 4263 4264 4265 4266 4267 4268 4269 | } } if (bodyShared) { Tcl_AppendResult(interp, "last non-finally clause must not have a body of \"-\"", NULL); Tcl_DecrRefCount(handlersObj); return TCL_ERROR; } if (!haveHandlers) { Tcl_DecrRefCount(handlersObj); handlersObj = NULL; } | > > | 4296 4297 4298 4299 4300 4301 4302 4303 4304 4305 4306 4307 4308 4309 4310 4311 | } } if (bodyShared) { Tcl_AppendResult(interp, "last non-finally clause must not have a body of \"-\"", NULL); Tcl_DecrRefCount(handlersObj); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "BADFALLTHROUGH", NULL); return TCL_ERROR; } if (!haveHandlers) { Tcl_DecrRefCount(handlersObj); handlersObj = NULL; } |
︙ | ︙ |
Changes to generic/tclConfig.c.
︙ | ︙ | |||
233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 | || pkgDict == NULL) { /* * Maybe a Tcl_Panic is better, because the package data has to be * present. */ Tcl_SetResult(interp, "package not known", TCL_STATIC); return TCL_ERROR; } switch ((enum subcmds) index) { case CFG_GET: if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "key"); return TCL_ERROR; } | > > | > > > | 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 | || pkgDict == NULL) { /* * Maybe a Tcl_Panic is better, because the package data has to be * present. */ Tcl_SetResult(interp, "package not known", TCL_STATIC); Tcl_SetErrorCode(interp, "TCL", "FATAL", "PKGCFG_BASE", Tcl_GetString(pkgName), NULL); return TCL_ERROR; } switch ((enum subcmds) index) { case CFG_GET: if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "key"); return TCL_ERROR; } if (Tcl_DictObjGet(interp, pkgDict, objv[2], &val) != TCL_OK || val == NULL) { Tcl_SetResult(interp, "key not known", TCL_STATIC); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CONFIG", Tcl_GetString(objv[2]), NULL); return TCL_ERROR; } Tcl_SetObjResult(interp, val); return TCL_OK; case CFG_LIST: if (objc != 2) { Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; } Tcl_DictObjSize(interp, pkgDict, &n); listPtr = Tcl_NewListObj(n, NULL); if (!listPtr) { Tcl_SetResult(interp, "insufficient memory to create list", TCL_STATIC); Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); return TCL_ERROR; } if (n) { List *listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; Tcl_DictSearch s; |
︙ | ︙ |
Changes to generic/tclUtil.c.
︙ | ︙ | |||
217 218 219 220 221 222 223 224 225 226 227 228 229 230 | && (!isspace(UCHAR(*p2))) /* INTL: ISO space. */ && (p2 < p+20)) { p2++; } Tcl_SetObjResult(interp, Tcl_ObjPrintf( "list element in braces followed by \"%.*s\" " "instead of space", (int) (p2-p), p)); } return TCL_ERROR; } break; /* * Backslash: skip over everything up to the end of the backslash | > > | 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 | && (!isspace(UCHAR(*p2))) /* INTL: ISO space. */ && (p2 < p+20)) { p2++; } Tcl_SetObjResult(interp, Tcl_ObjPrintf( "list element in braces followed by \"%.*s\" " "instead of space", (int) (p2-p), p)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "LIST", "JUNK", NULL); } return TCL_ERROR; } break; /* * Backslash: skip over everything up to the end of the backslash |
︙ | ︙ | |||
276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 | && (!isspace(UCHAR(*p2))) /* INTL: ISO space */ && (p2 < p+20)) { p2++; } Tcl_SetObjResult(interp, Tcl_ObjPrintf( "list element in quotes followed by \"%.*s\" " "instead of space", (int) (p2-p), p)); } return TCL_ERROR; } break; } p++; } /* * End of list: terminate element. */ if (p == limit) { if (openBraces != 0) { if (interp != NULL) { Tcl_SetResult(interp, "unmatched open brace in list", TCL_STATIC); } return TCL_ERROR; } else if (inQuotes) { if (interp != NULL) { Tcl_SetResult(interp, "unmatched open quote in list", TCL_STATIC); } return TCL_ERROR; } size = (p - elemStart); } done: | > > > > > > | 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 | && (!isspace(UCHAR(*p2))) /* INTL: ISO space */ && (p2 < p+20)) { p2++; } Tcl_SetObjResult(interp, Tcl_ObjPrintf( "list element in quotes followed by \"%.*s\" " "instead of space", (int) (p2-p), p)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "LIST", "JUNK", NULL); } return TCL_ERROR; } break; } p++; } /* * End of list: terminate element. */ if (p == limit) { if (openBraces != 0) { if (interp != NULL) { Tcl_SetResult(interp, "unmatched open brace in list", TCL_STATIC); Tcl_SetErrorCode(interp, "TCL", "VALUE", "LIST", "BRACE", NULL); } return TCL_ERROR; } else if (inQuotes) { if (interp != NULL) { Tcl_SetResult(interp, "unmatched open quote in list", TCL_STATIC); Tcl_SetErrorCode(interp, "TCL", "VALUE", "LIST", "QUOTE", NULL); } return TCL_ERROR; } size = (p - elemStart); } done: |
︙ | ︙ | |||
447 448 449 450 451 452 453 | *list != 0; i++) { const char *prevList = list; result = TclFindElement(interp, list, length, &element, &list, &elSize, &brace); length -= (list - prevList); if (result != TCL_OK) { | < < < | 455 456 457 458 459 460 461 462 463 464 465 466 467 468 | *list != 0; i++) { const char *prevList = list; result = TclFindElement(interp, list, length, &element, &list, &elSize, &brace); length -= (list - prevList); if (result != TCL_OK) { ckfree(argv); return result; } if (*element == 0) { break; } if (i >= size) { |
︙ | ︙ | |||
2115 2116 2117 2118 2119 2120 2121 | double value, /* Value to print as string. */ char *dst) /* Where to store converted value; must have * at least TCL_DOUBLE_SPACE characters. */ { char *p, c; int exponent; int signum; | | | < | | 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 | double value, /* Value to print as string. */ char *dst) /* Where to store converted value; must have * at least TCL_DOUBLE_SPACE characters. */ { char *p, c; int exponent; int signum; char *digits; char *end; int *precisionPtr = Tcl_GetThreadData(&precisionKey, (int) sizeof(int)); /* * Handle NaN. */ if (TclIsNaN(value)) { TclFormatNaN(value, dst); |
︙ | ︙ | |||
2152 2153 2154 2155 2156 2157 2158 | /* * Ordinary (normal and denormal) values. */ if (*precisionPtr == 0) { digits = TclDoubleDigits(value, -1, TCL_DD_SHORTEST, | | | | | | | | | | | | | | | | | | | | | | 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 | /* * Ordinary (normal and denormal) values. */ if (*precisionPtr == 0) { digits = TclDoubleDigits(value, -1, TCL_DD_SHORTEST, &exponent, &signum, &end); } else { /* * There are at least two possible interpretations for tcl_precision. * * The first is, "choose the decimal representation having * $tcl_precision digits of significance that is nearest to the given * number, breaking ties by rounding to even, and then trimming * trailing zeros." This gives the greatest possible precision in the * decimal string, but offers the anomaly that [expr 0.1] will be * "0.10000000000000001". * * The second is "choose the decimal representation having at most * $tcl_precision digits of significance that is nearest to the given * number. If no such representation converts exactly to the given * number, choose the one that is closest, breaking ties by rounding * to even. If more than one such representation converts exactly to * the given number, choose the shortest, breaking ties in favour of * the nearest, breaking remaining ties in favour of the one ending in * an even digit." * * Tcl 8.4 implements the first of these, which gives rise to * anomalies in formatting: * * % expr 0.1 * 0.10000000000000001 * % expr 0.01 * 0.01 * % expr 1e-7 * 9.9999999999999995e-08 * * For human readability, it appears better to choose the second rule, * and let [expr 0.1] return 0.1. But for 8.4 compatibility, we prefer * the first (the recommended zero value for tcl_precision avoids the * problem entirely). * * Uncomment TCL_DD_SHORTEN_FLAG in the next call to prefer the method * that allows floating point values to be shortened if it can be done * without loss of precision. */ digits = TclDoubleDigits(value, *precisionPtr, TCL_DD_E_FORMAT /* | TCL_DD_SHORTEN_FLAG */, &exponent, &signum, &end); } if (signum) { |
︙ | ︙ | |||
2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 | if (c != '\0') { *dst++ = '.'; while (c != '\0') { *dst++ = c; c = *++p; } } /* * Tcl 8.4 appears to format with at least a two-digit exponent; * preserve that behaviour when tcl_precision != 0 */ if (*precisionPtr == 0) { sprintf(dst, "e%+d", exponent); } else { sprintf(dst, "e%+03d", exponent); } } else { /* | > > | 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 | if (c != '\0') { *dst++ = '.'; while (c != '\0') { *dst++ = c; c = *++p; } } /* * Tcl 8.4 appears to format with at least a two-digit exponent; * preserve that behaviour when tcl_precision != 0 */ if (*precisionPtr == 0) { sprintf(dst, "e%+d", exponent); } else { sprintf(dst, "e%+03d", exponent); } } else { /* |
︙ | ︙ | |||
2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 | * Performance tweak. All ASCII spaces are <= 0x20. So get a quick * answer for most characters before comparing against all spaces in * the switch below. * * NOTE: Remove this if other Unicode spaces ever get accepted as * list-element separators. */ return 1; } switch (*end) { case ' ': case '\t': case '\n': case '\r': | > | 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 | * Performance tweak. All ASCII spaces are <= 0x20. So get a quick * answer for most characters before comparing against all spaces in * the switch below. * * NOTE: Remove this if other Unicode spaces ever get accepted as * list-element separators. */ return 1; } switch (*end) { case ' ': case '\t': case '\n': case '\r': |
︙ | ︙ | |||
2430 2431 2432 2433 2434 2435 2436 | *---------------------------------------------------------------------- * * TclFormatInt -- * * This procedure formats an integer into a sequence of decimal digit * characters in a buffer. If the integer is negative, a minus sign is * inserted at the start of the buffer. A null character is inserted at | | | | | | | | | 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 | *---------------------------------------------------------------------- * * TclFormatInt -- * * This procedure formats an integer into a sequence of decimal digit * characters in a buffer. If the integer is negative, a minus sign is * inserted at the start of the buffer. A null character is inserted at * the end of the formatted characters. It is the caller's responsibility * to ensure that enough storage is available. This procedure has the * effect of sprintf(buffer, "%ld", n) but is faster as proven in * benchmarks. This is key to UpdateStringOfInt, which is a common path * for a lot of code (e.g. int-indexed arrays). * * Results: * An integer representing the number of characters formatted, not * including the terminating \0. * * Side effects: * The formatted characters are written into the storage pointer to by * the "buffer" argument. * *---------------------------------------------------------------------- */ int TclFormatInt(buffer, n) char *buffer; /* Points to the storage into which the |
︙ | ︙ | |||
2729 2730 2731 2732 2733 2734 2735 | } else if ((length > 4) && ((bytes[3] == '-') || (bytes[3] == '+'))) { /* * This is our limited string expression evaluator. Pass everything * after "end-" to Tcl_GetInt, then reverse for offset. */ if (isspace(UCHAR(bytes[4]))) { | | > | 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 | } else if ((length > 4) && ((bytes[3] == '-') || (bytes[3] == '+'))) { /* * This is our limited string expression evaluator. Pass everything * after "end-" to Tcl_GetInt, then reverse for offset. */ if (isspace(UCHAR(bytes[4]))) { goto badIndexFormat; } if (Tcl_GetInt(interp, bytes+4, &offset) != TCL_OK) { return TCL_ERROR; } if (bytes[3] == '-') { offset = -offset; } } else { /* * Conversion failed. Report the error. */ badIndexFormat: if (interp != NULL) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "bad index \"", bytes, "\": must be end?[+-]integer?", NULL); Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", NULL); } return TCL_ERROR; |
︙ | ︙ | |||
2849 2850 2851 2852 2853 2854 2855 | Tcl_HashTable *tablePtr) { Tcl_HashSearch search; Tcl_HashEntry *hPtr; for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { | | > | 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 | Tcl_HashTable *tablePtr) { Tcl_HashSearch search; Tcl_HashEntry *hPtr; for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { Tcl_Obj *objPtr = Tcl_GetHashValue(hPtr); Tcl_DecrRefCount(objPtr); Tcl_DeleteHashEntry(hPtr); } } /* *---------------------------------------------------------------------- |
︙ | ︙ | |||
2906 2907 2908 2909 2910 2911 2912 | *---------------------------------------------------------------------- */ static void FreeThreadHash( ClientData clientData) { | | | 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 | *---------------------------------------------------------------------- */ static void FreeThreadHash( ClientData clientData) { Tcl_HashTable *tablePtr = clientData; ClearHash(tablePtr); Tcl_DeleteHashTable(tablePtr); ckfree(tablePtr); } /* |
︙ | ︙ | |||
2992 2993 2994 2995 2996 2997 2998 | * loss of the intrep. Increment newValue refCount early to handle case * where we set a PGV to itself. */ Tcl_IncrRefCount(newValue); cacheMap = GetThreadHash(&pgvPtr->key); ClearHash(cacheMap); | | < | 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 | * loss of the intrep. Increment newValue refCount early to handle case * where we set a PGV to itself. */ Tcl_IncrRefCount(newValue); cacheMap = GetThreadHash(&pgvPtr->key); ClearHash(cacheMap); hPtr = Tcl_CreateHashEntry(cacheMap, INT2PTR(pgvPtr->epoch), &dummy); Tcl_SetHashValue(hPtr, newValue); Tcl_MutexUnlock(&pgvPtr->mutex); } /* *---------------------------------------------------------------------- * |
︙ | ︙ | |||
3269 3270 3271 3272 3273 3274 3275 | /* * "***=xxx" == "*xxx*", watch for glob-sensitive chars. */ if ((reStrLen >= 4) && (memcmp("***=", reStr, 4) == 0)) { /* | | | > | 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 | /* * "***=xxx" == "*xxx*", watch for glob-sensitive chars. */ if ((reStrLen >= 4) && (memcmp("***=", reStr, 4) == 0)) { /* * At most, the glob pattern has length 2*reStrLen + 2 to backslash * escape every character and have * at each end. */ Tcl_DStringSetLength(dsPtr, reStrLen + 2); dsStr = dsStrStart = Tcl_DStringValue(dsPtr); *dsStr++ = '*'; for (p = reStr + 4; p < strEnd; p++) { switch (*p) { case '\\': case '*': case '[': case ']': case '?': /* Only add \ where necessary for glob */ |
︙ | ︙ | |||
3295 3296 3297 3298 3299 3300 3301 | if (exactPtr) { *exactPtr = 0; } return TCL_OK; } /* | | | | | < | 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 | if (exactPtr) { *exactPtr = 0; } return TCL_OK; } /* * At most, the glob pattern has length reStrLen + 2 to account for * possible * at each end. */ Tcl_DStringSetLength(dsPtr, reStrLen + 2); dsStr = dsStrStart = Tcl_DStringValue(dsPtr); /* * Check for anchored REs (ie ^foo$), so we can use string equal if * possible. Do not alter the start of str so we can free it correctly. * * Keep track of the last char being an unescaped star to prevent multiple * instances. Simpler than checking that the last star may be escaped. */ msg = NULL; p = reStr; anchorRight = 0; lastIsStar = 0; numStars = 0; |
︙ | ︙ | |||
3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 | lastIsStar = 0; } if (numStars > 1) { /* * Heuristic: if >1 non-anchoring *, the risk is large that glob * matching is slower than the RE engine, so report invalid. */ msg = "excessive recursive glob backtrack potential"; goto invalidGlob; } if (!anchorRight && !lastIsStar) { *dsStr++ = '*'; } | > | 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 | lastIsStar = 0; } if (numStars > 1) { /* * Heuristic: if >1 non-anchoring *, the risk is large that glob * matching is slower than the RE engine, so report invalid. */ msg = "excessive recursive glob backtrack potential"; goto invalidGlob; } if (!anchorRight && !lastIsStar) { *dsStr++ = '*'; } |
︙ | ︙ |