Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Overview
Comment: | Merge trunk |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors | descendants | both | apn-experiment-chardet |
Files: | files | file ages | folders |
SHA3-256: |
7e32c99c4fb79dcb132a61ed3889f02b |
User & Date: | apnadkarni 2024-06-15 09:56:47 |
Context
2024-06-18
| ||
17:09 | Merge trunk Closed-Leaf check-in: 96372d2b42 user: apnadkarni tags: apn-experiment-chardet | |
2024-06-15
| ||
09:56 | Merge trunk check-in: 7e32c99c4f user: apnadkarni tags: apn-experiment-chardet | |
2024-06-14
| ||
18:44 | Fix non-standard indentation pattern check-in: 9c2a4fb37d user: dkf tags: trunk, main | |
2024-06-13
| ||
15:51 | Remove migration utilities. Do not really belong here check-in: 639e370816 user: apnadkarni tags: apn-experiment-chardet | |
Changes
Changes to doc/configurable.n.
1 | '\" | | | 1 2 3 4 5 6 7 8 9 | '\" '\" Copyright (c) 2019 Donal K. Fellows '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH configurable n 0.4 TclOO "TclOO Commands" .so man.macros .BS |
︙ | ︙ |
Changes to generic/tclArithSeries.c.
︙ | ︙ | |||
497 498 499 500 501 502 503 | * Results: * A Tcl_Obj pointer. No assignment on error. * * Side Effects: * None. *---------------------------------------------------------------------- */ | | > > | > > | > > > | > | < > < > | > > | > > | | | > > | | 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 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 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 | * Results: * A Tcl_Obj pointer. No assignment on error. * * Side Effects: * None. *---------------------------------------------------------------------- */ static int assignNumber( Tcl_Interp *interp, int useDoubles, Tcl_WideInt *intNumberPtr, double *dblNumberPtr, Tcl_Obj *numberObj) { void *clientData; int tcl_number_type; if (Tcl_GetNumberFromObj(interp, numberObj, &clientData, &tcl_number_type) != TCL_OK) { return TCL_ERROR; } if (tcl_number_type == TCL_NUMBER_BIG) { /* bignum is not supported yet. */ Tcl_WideInt w; (void)Tcl_GetWideIntFromObj(interp, numberObj, &w); return TCL_ERROR; } if (useDoubles) { if (tcl_number_type != TCL_NUMBER_INT) { *dblNumberPtr = *(double *)clientData; } else { *dblNumberPtr = (double)*(Tcl_WideInt *)clientData; } } else { if (tcl_number_type == TCL_NUMBER_INT) { *intNumberPtr = *(Tcl_WideInt *)clientData; } else { *intNumberPtr = (Tcl_WideInt)*(double *)clientData; } } return TCL_OK; } /* *---------------------------------------------------------------------- * * TclNewArithSeriesObj -- * * Creates a new ArithSeries object. Some arguments may be NULL and will * be computed based on the other given arguments. * refcount = 0. * * Results: * A Tcl_Obj pointer to the created ArithSeries object. * NULL if the range is invalid. * * Side Effects: * None. *---------------------------------------------------------------------- */ Tcl_Obj * TclNewArithSeriesObj( Tcl_Interp *interp, /* For error reporting */ int useDoubles, /* Flag indicates values start, ** end, step, are treated as doubles */ Tcl_Obj *startObj, /* Starting value */ Tcl_Obj *endObj, /* Ending limit */ Tcl_Obj *stepObj, /* increment value */ Tcl_Obj *lenObj) /* Number of elements */ { double dstart, dend, dstep; Tcl_WideInt start, end, step; Tcl_WideInt len = -1; Tcl_Obj *objPtr; if (startObj) { if (assignNumber(interp, useDoubles, &start, &dstart, startObj) != TCL_OK) { return NULL; } } else { start = 0; dstart = start; } if (stepObj) { if (assignNumber(interp, useDoubles, &step, &dstep, stepObj) != TCL_OK) { return NULL; } if (useDoubles) { step = dstep; } else { dstep = step; } if (dstep == 0) { TclNewObj(objPtr); return objPtr; } } if (endObj) { if (assignNumber(interp, useDoubles, &end, &dend, endObj) != TCL_OK) { return NULL; } } if (lenObj) { if (TCL_OK != Tcl_GetWideIntFromObj(interp, lenObj, &len)) { return NULL; } } if (startObj && endObj) { if (!stepObj) { if (useDoubles) { dstep = (dstart < dend) ? 1.0 : -1.0; |
︙ | ︙ | |||
625 626 627 628 629 630 631 | } } if (len > TCL_SIZE_MAX) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "max length of a Tcl list exceeded", TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "MEMORY", (void *)NULL); | | < | < | | 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 | } } if (len > TCL_SIZE_MAX) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "max length of a Tcl list exceeded", TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "MEMORY", (void *)NULL); return NULL; } objPtr = (useDoubles) ? NewArithSeriesDbl(dstart, dend, dstep, len) : NewArithSeriesInt(start, end, step, len); return objPtr; } /* *---------------------------------------------------------------------- * * TclArithSeriesObjIndex -- * |
︙ | ︙ | |||
828 829 830 831 832 833 834 | TclArithSeriesObjIndex(interp, arithSeriesObj, fromIdx, &startObj); Tcl_IncrRefCount(startObj); TclArithSeriesObjIndex(interp, arithSeriesObj, toIdx, &endObj); Tcl_IncrRefCount(endObj); TclArithSeriesObjStep(arithSeriesObj, &stepObj); Tcl_IncrRefCount(stepObj); | | | | | | | 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 | TclArithSeriesObjIndex(interp, arithSeriesObj, fromIdx, &startObj); Tcl_IncrRefCount(startObj); TclArithSeriesObjIndex(interp, arithSeriesObj, toIdx, &endObj); Tcl_IncrRefCount(endObj); TclArithSeriesObjStep(arithSeriesObj, &stepObj); Tcl_IncrRefCount(stepObj); if (Tcl_IsShared(arithSeriesObj) || ((arithSeriesObj->refCount > 1))) { Tcl_Obj *newSlicePtr = TclNewArithSeriesObj(interp, arithSeriesRepPtr->isDouble, startObj, endObj, stepObj, NULL); *newObjPtr = newSlicePtr; Tcl_DecrRefCount(startObj); Tcl_DecrRefCount(endObj); Tcl_DecrRefCount(stepObj); return newSlicePtr ? TCL_OK : TCL_ERROR; } /* * In-place is possible. */ /* |
︙ | ︙ | |||
1039 1040 1041 1042 1043 1044 1045 | TclSetIntObj(stepObj, step); } if (Tcl_IsShared(arithSeriesObj) || (arithSeriesObj->refCount > 1)) { Tcl_Obj *lenObj; TclNewIntObj(lenObj, len); | | | < < | 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 | TclSetIntObj(stepObj, step); } if (Tcl_IsShared(arithSeriesObj) || (arithSeriesObj->refCount > 1)) { Tcl_Obj *lenObj; TclNewIntObj(lenObj, len); resultObj = TclNewArithSeriesObj(interp, isDouble, startObj, endObj, stepObj, lenObj); Tcl_DecrRefCount(lenObj); } else { /* * In-place is possible. */ TclInvalidateStringRep(arithSeriesObj); |
︙ | ︙ | |||
1073 1074 1075 1076 1077 1078 1079 | Tcl_DecrRefCount(startObj); Tcl_DecrRefCount(endObj); Tcl_DecrRefCount(stepObj); *newObjPtr = resultObj; | | | 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 | Tcl_DecrRefCount(startObj); Tcl_DecrRefCount(endObj); Tcl_DecrRefCount(stepObj); *newObjPtr = resultObj; return resultObj ? TCL_OK : TCL_ERROR; } /* *---------------------------------------------------------------------- * * UpdateStringOfArithSeries -- * |
︙ | ︙ |
Changes to generic/tclCmdIL.c.
︙ | ︙ | |||
98 99 100 101 102 103 104 | /* * Definitions for [lseq] command */ static const char *const seq_operations[] = { "..", "to", "count", "by", NULL }; | | | | | 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 | /* * Definitions for [lseq] command */ static const char *const seq_operations[] = { "..", "to", "count", "by", NULL }; typedef enum { LSEQ_DOTS, LSEQ_TO, LSEQ_COUNT, LSEQ_BY } SequenceOperators; typedef enum { NoneArg, NumericArg, RangeKeywordArg, ErrArg, LastArg = 8 } SequenceDecoded; /* * Forward declarations for procedures defined in this file: */ static int DictionaryCompare(const char *left, const char *right); |
︙ | ︙ | |||
4026 4027 4028 4029 4030 4031 4032 4033 4034 4035 | * pointer, numValuePtr reference count is incremented. */ static SequenceDecoded SequenceIdentifyArgument( Tcl_Interp *interp, /* for error reporting */ Tcl_Obj *argPtr, /* Argument to decode */ Tcl_Obj **numValuePtr, /* Return numeric value */ int *keywordIndexPtr) /* Return keyword enum */ { | > | > > > > > | | | | | | | > | | > > > > > > > < < > > > | < < > < > > | | | < < < | 4026 4027 4028 4029 4030 4031 4032 4033 4034 4035 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 4073 4074 4075 4076 4077 4078 4079 4080 4081 4082 4083 4084 4085 4086 4087 4088 4089 4090 4091 4092 | * pointer, numValuePtr reference count is incremented. */ static SequenceDecoded SequenceIdentifyArgument( Tcl_Interp *interp, /* for error reporting */ Tcl_Obj *argPtr, /* Argument to decode */ int allowedArgs, /* Flags if keyword or numeric allowed. */ Tcl_Obj **numValuePtr, /* Return numeric value */ int *keywordIndexPtr) /* Return keyword enum */ { int result = TCL_ERROR; SequenceOperators opmode; void *internalPtr; if (allowedArgs & NumericArg) { /* speed-up a bit (and avoid shimmer for compiled expressions) */ if (TclHasInternalRep(argPtr, &tclExprCodeType)) { goto doExpr; } result = Tcl_GetNumberFromObj(NULL, argPtr, &internalPtr, keywordIndexPtr); if (result == TCL_OK) { *numValuePtr = argPtr; Tcl_IncrRefCount(argPtr); return NumericArg; } } if (allowedArgs & RangeKeywordArg) { result = Tcl_GetIndexFromObj(NULL, argPtr, seq_operations, "range operation", 0, &opmode); } if (result == TCL_OK) { if (allowedArgs & LastArg) { /* keyword found, but no followed number */ Tcl_SetObjResult(interp, Tcl_ObjPrintf( "missing \"%s\" value.", TclGetString(argPtr))); return ErrArg; } *keywordIndexPtr = opmode; return RangeKeywordArg; } else { Tcl_Obj *exprValueObj; if (!(allowedArgs & NumericArg)) { return NoneArg; } doExpr: /* Check for an index expression */ if (Tcl_ExprObj(interp, argPtr, &exprValueObj) != TCL_OK) { return ErrArg; } int keyword; /* Determine if result of expression is double or int */ if (Tcl_GetNumberFromObj(interp, exprValueObj, &internalPtr, &keyword) != TCL_OK ) { return ErrArg; } *numValuePtr = exprValueObj; /* incremented in Tcl_ExprObj */ *keywordIndexPtr = keyword; /* type of expression result */ return NumericArg; } } /* *---------------------------------------------------------------------- * * Tcl_LseqObjCmd -- |
︙ | ︙ | |||
4118 4119 4120 4121 4122 4123 4124 | Tcl_Obj *const objv[]) /* The argument objects. */ { Tcl_Obj *elementCount = NULL; Tcl_Obj *start = NULL, *end = NULL, *step = NULL; Tcl_WideInt values[5]; Tcl_Obj *numValues[5]; Tcl_Obj *numberObj; | | > | | > | | | | > > | < | | | | | | | | | > | > > > > > | | | | | | | > | | | | | < | | < < < < < < < | 4130 4131 4132 4133 4134 4135 4136 4137 4138 4139 4140 4141 4142 4143 4144 4145 4146 4147 4148 4149 4150 4151 4152 4153 4154 4155 4156 4157 4158 4159 4160 4161 4162 4163 4164 4165 4166 4167 4168 4169 4170 4171 4172 4173 4174 4175 4176 4177 4178 4179 4180 4181 4182 4183 4184 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 | Tcl_Obj *const objv[]) /* The argument objects. */ { Tcl_Obj *elementCount = NULL; Tcl_Obj *start = NULL, *end = NULL, *step = NULL; Tcl_WideInt values[5]; Tcl_Obj *numValues[5]; Tcl_Obj *numberObj; int status = TCL_ERROR, keyword, useDoubles = 0, allowedArgs = NumericArg; int remNums = 3; Tcl_Obj *arithSeriesPtr; SequenceOperators opmode; SequenceDecoded decoded; int i, arg_key = 0, value_i = 0; /* Default constants */ #define zero ((Interp *)interp)->execEnvPtr->constants[0]; #define one ((Interp *)interp)->execEnvPtr->constants[1]; /* * Create a decoding key by looping through the arguments and identify * what kind of argument each one is. Encode each argument as a decimal * digit. */ if (objc > 6) { /* Too many arguments */ goto syntax; } for (i = 1; i < objc; i++) { arg_key = (arg_key * 10); numValues[value_i] = NULL; decoded = SequenceIdentifyArgument(interp, objv[i], allowedArgs | (i == objc-1 ? LastArg : 0), &numberObj, &keyword); switch (decoded) { case NoneArg: /* * Unrecognizable argument * Reproduce operation error message */ status = Tcl_GetIndexFromObj(interp, objv[i], seq_operations, "operation", 0, &opmode); goto done; case NumericArg: remNums--; arg_key += NumericArg; allowedArgs = RangeKeywordArg; /* if last number but 2 arguments remain, next is not numeric */ if ((remNums != 1) || ((objc-1-i) != 2)) { allowedArgs |= NumericArg; } numValues[value_i] = numberObj; values[value_i] = keyword; /* TCL_NUMBER_* */ useDoubles |= (keyword == TCL_NUMBER_DOUBLE) ? 1 : 0; value_i++; break; case RangeKeywordArg: arg_key += RangeKeywordArg; allowedArgs = NumericArg; /* after keyword always numeric only */ values[value_i] = keyword; /* SequenceOperators */ value_i++; break; default: /* Error state */ status = TCL_ERROR; goto done; } } /* * The key encoding defines a valid set of arguments, or indicates an * error condition; process the values accordningly. */ switch (arg_key) { /* lseq n */ case 1: start = zero; elementCount = numValues[0]; end = NULL; step = one; break; |
︙ | ︙ | |||
4305 4306 4307 4308 4309 4310 4311 | break; default: goto done; break; } break; | < < < < < < < < < < < < < < < < < < < < < < < < < < > | 4319 4320 4321 4322 4323 4324 4325 4326 4327 4328 4329 4330 4331 4332 4333 4334 4335 | break; default: goto done; break; } break; /* All other argument errors */ default: syntax: Tcl_WrongNumArgs(interp, 1, objv, "n ??op? n ??by? n??"); goto done; break; } /* Count needs to be integer, so try to convert if possible */ if (elementCount && TclHasInternalRep(elementCount, &tclDoubleType)) { |
︙ | ︙ | |||
4362 4363 4364 4365 4366 4367 4368 | } } /* * Success! Now lets create the series object. */ | | > > | | 4351 4352 4353 4354 4355 4356 4357 4358 4359 4360 4361 4362 4363 4364 4365 4366 4367 4368 4369 4370 | } } /* * Success! Now lets create the series object. */ arithSeriesPtr = TclNewArithSeriesObj(interp, useDoubles, start, end, step, elementCount); status = TCL_ERROR; if (arithSeriesPtr) { status = TCL_OK; Tcl_SetObjResult(interp, arithSeriesPtr); } done: // Free number arguments. while (--value_i>=0) { if (numValues[value_i]) { |
︙ | ︙ |
Changes to generic/tclEncoding.c.
︙ | ︙ | |||
30 31 32 33 34 35 36 | * into UTF-8. */ Tcl_EncodingConvertProc *fromUtfProc; /* Function to convert from UTF-8 into * external encoding. */ Tcl_EncodingFreeProc *freeProc; /* If non-NULL, function to call when this * encoding is deleted. */ | | | | 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 | * into UTF-8. */ Tcl_EncodingConvertProc *fromUtfProc; /* Function to convert from UTF-8 into * external encoding. */ Tcl_EncodingFreeProc *freeProc; /* If non-NULL, function to call when this * encoding is deleted. */ void *clientData; /* Arbitrary value associated with encoding * type. Passed to conversion functions. */ Tcl_Size nullSize; /* Number of 0x00 bytes that signify * end-of-string in this encoding. This number * is used to determine the source string * length when the srcLen argument is * negative. This number can be 1, 2, or 4. */ LengthProc *lengthProc; /* Function to compute length of * null-terminated strings in this encoding. * If nullSize is 1, this is strlen; if |
︙ | ︙ | |||
115 116 117 118 119 120 121 | * conversion. */ char prefixBytes[256]; /* If a byte in the input stream is the first * character of one of the escape sequences in * the following array, the corresponding * entry in this array is 1, otherwise it is * 0. */ int numSubTables; /* Length of following array. */ | | > | 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 | * conversion. */ char prefixBytes[256]; /* If a byte in the input stream is the first * character of one of the escape sequences in * the following array, the corresponding * entry in this array is 1, otherwise it is * 0. */ int numSubTables; /* Length of following array. */ EscapeSubTable subTables[TCLFLEXARRAY]; /* Information about each EscapeSubTable used * by this encoding type. The actual size is * as large as necessary to hold all * EscapeSubTables. */ } EscapeEncodingData; /* * Constants used when loading an encoding file to identify the type of the |
︙ | ︙ | |||
197 198 199 200 201 202 203 | int value; } encodingProfiles[] = { {"replace", TCL_ENCODING_PROFILE_REPLACE}, {"strict", TCL_ENCODING_PROFILE_STRICT}, {"tcl8", TCL_ENCODING_PROFILE_TCL8}, }; | | | | | | | | 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 | int value; } encodingProfiles[] = { {"replace", TCL_ENCODING_PROFILE_REPLACE}, {"strict", TCL_ENCODING_PROFILE_STRICT}, {"tcl8", TCL_ENCODING_PROFILE_TCL8}, }; #define PROFILE_TCL8(flags_) \ (ENCODING_PROFILE_GET(flags_) == TCL_ENCODING_PROFILE_TCL8) #define PROFILE_REPLACE(flags_) \ (ENCODING_PROFILE_GET(flags_) == TCL_ENCODING_PROFILE_REPLACE) #define PROFILE_STRICT(flags_) \ (!PROFILE_TCL8(flags_) && !PROFILE_REPLACE(flags_)) #define UNICODE_REPLACE_CHAR 0xFFFD #define SURROGATE(c_) (((c_) & ~0x7FF) == 0xD800) #define HIGH_SURROGATE(c_) (((c_) & ~0x3FF) == 0xD800) #define LOW_SURROGATE(c_) (((c_) & ~0x3FF) == 0xDC00) /* * The following variable is used in the sparse matrix code for a * TableEncoding to represent a page in the table that has no entries. */ static unsigned short emptyPage[256]; |
︙ | ︙ | |||
255 256 257 258 259 260 261 | static Tcl_EncodingConvertProc UtfToUtf16Proc; static Tcl_EncodingConvertProc UtfToUcs2Proc; static Tcl_EncodingConvertProc UtfToUtfProc; static Tcl_EncodingConvertProc Iso88591FromUtfProc; static Tcl_EncodingConvertProc Iso88591ToUtfProc; /* | | | | | 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 | static Tcl_EncodingConvertProc UtfToUtf16Proc; static Tcl_EncodingConvertProc UtfToUcs2Proc; static Tcl_EncodingConvertProc UtfToUtfProc; static Tcl_EncodingConvertProc Iso88591FromUtfProc; static Tcl_EncodingConvertProc Iso88591ToUtfProc; /* * A Tcl_ObjType for holding a cached Tcl_Encoding in the twoPtrValue.ptr1 * field of the internalrep. This should help the lifetime of encodings be more * useful. See concerns raised in [Bug 1077262]. */ static const Tcl_ObjType encodingType = { "encoding", FreeEncodingInternalRep, DupEncodingInternalRep, NULL, |
︙ | ︙ | |||
506 507 508 509 510 511 512 | /* * NOTE: THESE BIT DEFINITIONS SHOULD NOT OVERLAP WITH INTERNAL USE BITS * DEFINED IN tcl.h (TCL_ENCODING_* et al). Be cognizant of this * when adding bits. TODO - should really be defined in a single file. * * To prevent conflicting bits, only define bits within 0xff00 mask here. */ | > | | > | > > | 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 | /* * NOTE: THESE BIT DEFINITIONS SHOULD NOT OVERLAP WITH INTERNAL USE BITS * DEFINED IN tcl.h (TCL_ENCODING_* et al). Be cognizant of this * when adding bits. TODO - should really be defined in a single file. * * To prevent conflicting bits, only define bits within 0xff00 mask here. */ enum InternalEncodingFlags { TCL_ENCODING_LE = 0x100, /* Used to distinguish LE/BE variants */ ENCODING_UTF = 0x200, /* For UTF-8 encoding, allow 4-byte output * sequences */ ENCODING_INPUT = 0x400 /* For UTF-8/CESU-8 encoding, means * external -> internal */ }; void TclInitEncodingSubsystem(void) { Tcl_EncodingType type; TableEncodingData *dataPtr; unsigned size; |
︙ | ︙ | |||
561 562 563 564 565 566 567 | type.clientData = INT2PTR(ENCODING_UTF); tclUtf8Encoding = Tcl_CreateEncoding(&type); type.clientData = NULL; type.encodingName = "cesu-8"; Tcl_CreateEncoding(&type); type.toUtfProc = Utf16ToUtfProc; | | | | | | | | | | | | | | 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 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 | type.clientData = INT2PTR(ENCODING_UTF); tclUtf8Encoding = Tcl_CreateEncoding(&type); type.clientData = NULL; type.encodingName = "cesu-8"; Tcl_CreateEncoding(&type); type.toUtfProc = Utf16ToUtfProc; type.fromUtfProc = UtfToUcs2Proc; type.freeProc = NULL; type.nullSize = 2; type.encodingName = "ucs-2le"; type.clientData = INT2PTR(TCL_ENCODING_LE); Tcl_CreateEncoding(&type); type.encodingName = "ucs-2be"; type.clientData = NULL; Tcl_CreateEncoding(&type); type.encodingName = "ucs-2"; type.clientData = INT2PTR(leFlags); Tcl_CreateEncoding(&type); type.toUtfProc = Utf32ToUtfProc; type.fromUtfProc = UtfToUtf32Proc; type.freeProc = NULL; type.nullSize = 4; type.encodingName = "utf-32le"; type.clientData = INT2PTR(TCL_ENCODING_LE); Tcl_CreateEncoding(&type); type.encodingName = "utf-32be"; type.clientData = NULL; Tcl_CreateEncoding(&type); type.encodingName = "utf-32"; type.clientData = INT2PTR(leFlags); Tcl_CreateEncoding(&type); type.toUtfProc = Utf16ToUtfProc; type.fromUtfProc = UtfToUtf16Proc; type.freeProc = NULL; type.nullSize = 2; type.encodingName = "utf-16le"; type.clientData = INT2PTR(TCL_ENCODING_LE); Tcl_CreateEncoding(&type); type.encodingName = "utf-16be"; type.clientData = NULL; Tcl_CreateEncoding(&type); type.encodingName = "utf-16"; type.clientData = INT2PTR(leFlags); Tcl_CreateEncoding(&type); #ifndef TCL_NO_DEPRECATED type.encodingName = "unicode"; Tcl_CreateEncoding(&type); #endif /* * Need the iso8859-1 encoding in order to process binary data, so force * it to always be embedded. Note that this encoding *must* be a proper * table encoding or some of the escape encodings crash! Hence the ugly |
︙ | ︙ | |||
920 921 922 923 924 925 926 | /* *------------------------------------------------------------------------- * * Tcl_GetEncodingNulLength -- * * Given an encoding, return the number of nul bytes used for the | | | 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 | /* *------------------------------------------------------------------------- * * Tcl_GetEncodingNulLength -- * * Given an encoding, return the number of nul bytes used for the * string termination. * * Results: * The number of nul bytes used for the string termination. * * Side effects: * None. * |
︙ | ︙ | |||
1120 1121 1122 1123 1124 1125 1126 | * "flags" controls the behavior if any of the bytes in * the source buffer are invalid or cannot be represented in utf-8. * Possible flags values: * target encoding. It should be composed by OR-ing the following: * - *At most one* of TCL_ENCODING_PROFILE{DEFAULT,TCL8,STRICT} * * Results: | | | | | | | | < | | | | | | | | | | | | | | 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 | * "flags" controls the behavior if any of the bytes in * the source buffer are invalid or cannot be represented in utf-8. * Possible flags values: * target encoding. It should be composed by OR-ing the following: * - *At most one* of TCL_ENCODING_PROFILE{DEFAULT,TCL8,STRICT} * * Results: * The return value is one of * TCL_OK: success. Converted string in *dstPtr * TCL_ERROR: error in passed parameters. Error message in interp * TCL_CONVERT_MULTIBYTE: source ends in truncated multibyte sequence * TCL_CONVERT_SYNTAX: source is not conformant to encoding definition * TCL_CONVERT_UNKNOWN: source contained a character that could not * be represented in target encoding. * * Side effects: * TCL_OK: The converted bytes are stored in the DString and NUL * terminated in an encoding-specific manner. * TCL_ERROR: an error, message is stored in the interp if not NULL. * TCL_CONVERT_*: if errorLocPtr is NULL, an error message is stored * in the interpreter (if not NULL). If errorLocPtr is not NULL, * no error message is stored as it is expected the caller is * interested in whatever is decoded so far and not treating this * as an error condition. * * In addition, *dstPtr is always initialized and must be cleared * by the caller irrespective of the return code. * *------------------------------------------------------------------------- */ int Tcl_ExternalToUtfDStringEx( Tcl_Interp *interp, /* For error messages. May be NULL. */ Tcl_Encoding encoding, /* The encoding for the source string, or NULL * for the default system encoding. */ const char *src, /* Source string in specified encoding. */ Tcl_Size srcLen, /* Source string length in bytes, or < 0 for * encoding-specific string length. */ int flags, /* Conversion control flags. */ Tcl_DString *dstPtr, /* Uninitialized or free DString in which the * converted string is stored. */ Tcl_Size *errorLocPtr) /* Where to store the error location * (or TCL_INDEX_NONE if no error). May * be NULL. */ { char *dst; Tcl_EncodingState state; const Encoding *encodingPtr; int result; Tcl_Size dstLen, soFar; |
︙ | ︙ | |||
1227 1228 1229 1230 1231 1232 1233 | Tcl_DStringSetLength(dstPtr, soFar); if (errorLocPtr) { /* * Do not write error message into interpreter if caller * wants to know error location. */ | | > | > | > | 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 | Tcl_DStringSetLength(dstPtr, soFar); if (errorLocPtr) { /* * Do not write error message into interpreter if caller * wants to know error location. */ *errorLocPtr = result == TCL_OK ? TCL_INDEX_NONE : nBytesProcessed; } else { /* Caller wants error message on failure */ if (result != TCL_OK && interp != NULL) { char buf[TCL_INTEGER_SPACE]; snprintf(buf, sizeof(buf), "%" TCL_SIZE_MODIFIER "d", nBytesProcessed); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unexpected byte sequence starting at index %" TCL_SIZE_MODIFIER "d: '\\x%02X'", nBytesProcessed, UCHAR(srcStart[nBytesProcessed]))); Tcl_SetErrorCode( interp, "TCL", "ENCODING", "ILLEGALSEQUENCE", buf, (void *)NULL); } } if (result != TCL_OK) { errno = (result == TCL_CONVERT_NOSPACE) ? ENOMEM : EILSEQ; } return result; } |
︙ | ︙ | |||
1283 1284 1285 1286 1287 1288 1289 | int Tcl_ExternalToUtf( TCL_UNUSED(Tcl_Interp *), /* TODO: Re-examine this. */ Tcl_Encoding encoding, /* The encoding for the source string, or NULL * for the default system encoding. */ const char *src, /* Source string in specified encoding. */ | | | > | 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 | int Tcl_ExternalToUtf( TCL_UNUSED(Tcl_Interp *), /* TODO: Re-examine this. */ Tcl_Encoding encoding, /* The encoding for the source string, or NULL * for the default system encoding. */ const char *src, /* Source string in specified encoding. */ Tcl_Size srcLen, /* Source string length in bytes, or * TCL_INDEX_NONE for encoding-specific string * length. */ int flags, /* Conversion control flags. */ Tcl_EncodingState *statePtr,/* Place for conversion routine to store state * information used during a piecewise * conversion. Contents of statePtr are * initialized and/or reset by conversion * routine under control of flags argument. */ char *dst, /* Output buffer in which converted string is |
︙ | ︙ | |||
1436 1437 1438 1439 1440 1441 1442 | * Convert a source buffer from UTF-8 to the specified encoding. * The parameter flags controls the behavior, if any of the bytes in * the source buffer are invalid or cannot be represented in the * target encoding. It should be composed by OR-ing the following: * - *At most one* of TCL_ENCODING_PROFILE_* * * Results: | | | | | | | | < | | | | | | | | | | | | | | 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 | * Convert a source buffer from UTF-8 to the specified encoding. * The parameter flags controls the behavior, if any of the bytes in * the source buffer are invalid or cannot be represented in the * target encoding. It should be composed by OR-ing the following: * - *At most one* of TCL_ENCODING_PROFILE_* * * Results: * The return value is one of * TCL_OK: success. Converted string in *dstPtr * TCL_ERROR: error in passed parameters. Error message in interp * TCL_CONVERT_MULTIBYTE: source ends in truncated multibyte sequence * TCL_CONVERT_SYNTAX: source is not conformant to encoding definition * TCL_CONVERT_UNKNOWN: source contained a character that could not * be represented in target encoding. * * Side effects: * TCL_OK: The converted bytes are stored in the DString and NUL * terminated in an encoding-specific manner * TCL_ERROR: an error, message is stored in the interp if not NULL. * TCL_CONVERT_*: if errorLocPtr is NULL, an error message is stored * in the interpreter (if not NULL). If errorLocPtr is not NULL, * no error message is stored as it is expected the caller is * interested in whatever is decoded so far and not treating this * as an error condition. * * In addition, *dstPtr is always initialized and must be cleared * by the caller irrespective of the return code. * *------------------------------------------------------------------------- */ int Tcl_UtfToExternalDStringEx( Tcl_Interp *interp, /* For error messages. May be NULL. */ Tcl_Encoding encoding, /* The encoding for the converted string, or * NULL for the default system encoding. */ const char *src, /* Source string in UTF-8. */ Tcl_Size srcLen, /* Source string length in bytes, or < 0 for * strlen(). */ int flags, /* Conversion control flags. */ Tcl_DString *dstPtr, /* Uninitialized or free DString in which the * converted string is stored. */ Tcl_Size *errorLocPtr) /* Where to store the error location * (or TCL_INDEX_NONE if no error). May * be NULL. */ { char *dst; Tcl_EncodingState state; const Encoding *encodingPtr; int result; const char *srcStart = src; |
︙ | ︙ | |||
1543 1544 1545 1546 1547 1548 1549 | Tcl_DStringSetLength(dstPtr, i--); } if (errorLocPtr) { /* * Do not write error message into interpreter if caller * wants to know error location. */ | | > | > | 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 1575 | Tcl_DStringSetLength(dstPtr, i--); } if (errorLocPtr) { /* * Do not write error message into interpreter if caller * wants to know error location. */ *errorLocPtr = result == TCL_OK ? TCL_INDEX_NONE : nBytesProcessed; } else { /* Caller wants error message on failure */ if (result != TCL_OK && interp != NULL) { Tcl_Size pos = Tcl_NumUtfChars(srcStart, nBytesProcessed); int ucs4; char buf[TCL_INTEGER_SPACE]; TclUtfToUniChar(&srcStart[nBytesProcessed], &ucs4); snprintf(buf, sizeof(buf), "%" TCL_SIZE_MODIFIER "d", nBytesProcessed); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unexpected character at index %" TCL_SIZE_MODIFIER "u: 'U+%06X'", pos, ucs4)); Tcl_SetErrorCode(interp, "TCL", "ENCODING", "ILLEGALSEQUENCE", buf, (void *)NULL); } |
︙ | ︙ | |||
1603 1604 1605 1606 1607 1608 1609 | int Tcl_UtfToExternal( TCL_UNUSED(Tcl_Interp *), /* TODO: Re-examine this. */ Tcl_Encoding encoding, /* The encoding for the converted string, or * NULL for the default system encoding. */ const char *src, /* Source string in UTF-8. */ | | | | 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 | int Tcl_UtfToExternal( TCL_UNUSED(Tcl_Interp *), /* TODO: Re-examine this. */ Tcl_Encoding encoding, /* The encoding for the converted string, or * NULL for the default system encoding. */ const char *src, /* Source string in UTF-8. */ Tcl_Size srcLen, /* Source string length in bytes, or * TCL_INDEX_NONE for strlen(). */ int flags, /* Conversion control flags. */ Tcl_EncodingState *statePtr,/* Place for conversion routine to store state * information used during a piecewise * conversion. Contents of statePtr are * initialized and/or reset by conversion * routine under control of flags argument. */ char *dst, /* Output buffer in which converted string |
︙ | ︙ | |||
1812 1813 1814 1815 1816 1817 1818 | TclSetProcessGlobalValue(&encodingFileMap, map); } } if ((NULL == chan) && (interp != NULL)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unknown encoding \"%s\"", name)); | | > | 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 | TclSetProcessGlobalValue(&encodingFileMap, map); } } if ((NULL == chan) && (interp != NULL)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unknown encoding \"%s\"", name)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENCODING", name, (void *)NULL); } Tcl_DecrRefCount(fileNameObj); Tcl_DecrRefCount(searchPath); return chan; } |
︙ | ︙ | |||
1886 1887 1888 1889 1890 1891 1892 | case 'E': encoding = LoadEscapeEncoding(name, chan); break; } if ((encoding == NULL) && (interp != NULL)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "invalid encoding file \"%s\"", name)); | | > | 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 | case 'E': encoding = LoadEscapeEncoding(name, chan); break; } if ((encoding == NULL) && (interp != NULL)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "invalid encoding file \"%s\"", name)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENCODING", name, (void *)NULL); } Tcl_CloseEx(NULL, chan, 0); return encoding; } /* |
︙ | ︙ | |||
2276 2277 2278 2279 2280 2281 2282 | /* * To avoid infinite recursion in [encoding system iso2022-*] */ e = (Encoding *) Tcl_GetEncoding(NULL, est.name); if ((e != NULL) && (e->toUtfProc != TableToUtfProc) && (e->toUtfProc != Iso88591ToUtfProc)) { | | | | 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 | /* * To avoid infinite recursion in [encoding system iso2022-*] */ e = (Encoding *) Tcl_GetEncoding(NULL, est.name); if ((e != NULL) && (e->toUtfProc != TableToUtfProc) && (e->toUtfProc != Iso88591ToUtfProc)) { Tcl_FreeEncoding((Tcl_Encoding) e); e = NULL; } est.encodingPtr = e; Tcl_DStringAppend(&escapeData, (char *) &est, sizeof(est)); } } Tcl_Free(argv); Tcl_DStringFree(&lineString); |
︙ | ︙ | |||
2464 2465 2466 2467 2468 2469 2470 | result = TCL_CONVERT_MULTIBYTE; break; } if (dst > dstEnd) { result = TCL_CONVERT_NOSPACE; break; } | > | | | | | | | 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 | result = TCL_CONVERT_MULTIBYTE; break; } if (dst > dstEnd) { result = TCL_CONVERT_NOSPACE; break; } if (UCHAR(*src) < 0x80 && !((UCHAR(*src) == 0) && (flags & ENCODING_INPUT))) { /* * Copy 7bit characters, but skip null-bytes when we are in input * mode, so that they get converted to \xC0\x80. */ *dst++ = *src++; } else if ((UCHAR(*src) == 0xC0) && (src + 1 < srcEnd) && (UCHAR(src[1]) == 0x80) && (!(flags & ENCODING_INPUT) || !PROFILE_TCL8(profile))) { /* Special sequence \xC0\x80 */ if (!PROFILE_TCL8(profile) && (flags & ENCODING_INPUT)) { if (PROFILE_REPLACE(profile)) { dst += Tcl_UniCharToUtf(UNICODE_REPLACE_CHAR, dst); src += 2; } else { /* PROFILE_STRICT */ result = TCL_CONVERT_SYNTAX; break; } } else { /* * Convert 0xC080 to real nulls when we are in output mode, * irrespective of the profile. */ *dst++ = 0; |
︙ | ︙ | |||
2505 2506 2507 2508 2509 2510 2511 | * the user has explicitly asked to be told. */ if (flags & ENCODING_INPUT) { /* Incomplete bytes for modified UTF-8 target */ if (PROFILE_STRICT(profile)) { result = (flags & TCL_ENCODING_CHAR_LIMIT) | | | | > | > | > | 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 | * the user has explicitly asked to be told. */ if (flags & ENCODING_INPUT) { /* Incomplete bytes for modified UTF-8 target */ if (PROFILE_STRICT(profile)) { result = (flags & TCL_ENCODING_CHAR_LIMIT) ? TCL_CONVERT_MULTIBYTE : TCL_CONVERT_SYNTAX; break; } } if (PROFILE_REPLACE(profile)) { ch = UNICODE_REPLACE_CHAR; ++src; } else { /* TCL_ENCODING_PROFILE_TCL8 */ char chbuf[2]; chbuf[0] = UCHAR(*src++); chbuf[1] = 0; TclUtfToUniChar(chbuf, &ch); } dst += Tcl_UniCharToUtf(ch, dst); } else { size_t len = TclUtfToUniChar(src, &ch); if (flags & ENCODING_INPUT) { if (((len < 2) && (ch != 0)) || ((ch > 0xFFFF) && !(flags & ENCODING_UTF))) { if (PROFILE_STRICT(profile)) { result = TCL_CONVERT_SYNTAX; break; } else if (PROFILE_REPLACE(profile)) { ch = UNICODE_REPLACE_CHAR; } } } const char *saveSrc = src; src += len; if (!(flags & ENCODING_UTF) && !(flags & ENCODING_INPUT) && (ch > 0x3FF)) { if (ch > 0xFFFF) { /* CESU-8 6-byte sequence for chars > U+FFFF */ ch -= 0x10000; *dst++ = 0xED; *dst++ = (char) (((ch >> 16) & 0x0F) | 0xA0); *dst++ = (char) (((ch >> 10) & 0x3F) | 0x80); ch = (ch & 0x0CFF) | 0xDC00; } *dst++ = (char)(((ch >> 12) | 0xE0) & 0xEF); *dst++ = (char)(((ch >> 6) | 0x80) & 0xBF); *dst++ = (char)((ch | 0x80) & 0xBF); continue; } else if (SURROGATE(ch)) { if (PROFILE_STRICT(profile)) { result = (flags & ENCODING_INPUT) ? TCL_CONVERT_SYNTAX : TCL_CONVERT_UNKNOWN; src = saveSrc; break; } else if (PROFILE_REPLACE(profile)) { ch = UNICODE_REPLACE_CHAR; } } dst += Tcl_UniCharToUtf(ch, dst); |
︙ | ︙ | |||
2585 2586 2587 2588 2589 2590 2591 | * None. * *------------------------------------------------------------------------- */ static int Utf32ToUtfProc( | | | 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 | * None. * *------------------------------------------------------------------------- */ static int Utf32ToUtfProc( void *clientData, /* additional flags, e.g. TCL_ENCODING_LE */ const char *src, /* Source string in Unicode. */ int srcLen, /* Source string length in bytes. */ int flags, /* Conversion control flags. */ TCL_UNUSED(Tcl_EncodingState *), char *dst, /* Output buffer in which converted string is * stored. */ int dstLen, /* The maximum length of output buffer in |
︙ | ︙ | |||
2639 2640 2641 2642 2643 2644 2645 | for (numChars = 0; src < srcEnd && numChars <= charLimit; numChars++) { if (dst > dstEnd) { result = TCL_CONVERT_NOSPACE; break; } if (flags & TCL_ENCODING_LE) { | | > | > | 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 | for (numChars = 0; src < srcEnd && numChars <= charLimit; numChars++) { if (dst > dstEnd) { result = TCL_CONVERT_NOSPACE; break; } if (flags & TCL_ENCODING_LE) { ch = (unsigned int)(src[3] & 0xFF) << 24 | (src[2] & 0xFF) << 16 | (src[1] & 0xFF) << 8 | (src[0] & 0xFF); } else { ch = (unsigned int)(src[0] & 0xFF) << 24 | (src[1] & 0xFF) << 16 | (src[2] & 0xFF) << 8 | (src[3] & 0xFF); } if ((unsigned)ch > 0x10FFFF) { if (PROFILE_STRICT(flags)) { result = TCL_CONVERT_SYNTAX; break; } ch = UNICODE_REPLACE_CHAR; |
︙ | ︙ | |||
2714 2715 2716 2717 2718 2719 2720 | * None. * *------------------------------------------------------------------------- */ static int UtfToUtf32Proc( | | | 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 | * None. * *------------------------------------------------------------------------- */ static int UtfToUtf32Proc( void *clientData, /* additional flags, e.g. TCL_ENCODING_LE */ const char *src, /* Source string in UTF-8. */ int srcLen, /* Source string length in bytes. */ int flags, /* Conversion control flags. */ TCL_UNUSED(Tcl_EncodingState *), char *dst, /* Output buffer in which converted string is * stored. */ int dstLen, /* The maximum length of output buffer in |
︙ | ︙ | |||
2813 2814 2815 2816 2817 2818 2819 | * None. * *------------------------------------------------------------------------- */ static int Utf16ToUtfProc( | | | 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 | * None. * *------------------------------------------------------------------------- */ static int Utf16ToUtfProc( void *clientData, /* additional flags, e.g. TCL_ENCODING_LE */ const char *src, /* Source string in Unicode. */ int srcLen, /* Source string length in bytes. */ int flags, /* Conversion control flags. */ TCL_UNUSED(Tcl_EncodingState *), char *dst, /* Output buffer in which converted string is * stored. */ int dstLen, /* The maximum length of output buffer in |
︙ | ︙ | |||
2871 2872 2873 2874 2875 2876 2877 | srcStart = src; srcEnd = src + srcLen; dstStart = dst; dstEnd = dst + dstLen - TCL_UTF_MAX; | | > | | | | > | > > | 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 | srcStart = src; srcEnd = src + srcLen; dstStart = dst; dstEnd = dst + dstLen - TCL_UTF_MAX; for (numChars = 0; src < srcEnd && numChars <= charLimit; src += 2, numChars++) { if (dst > dstEnd) { result = TCL_CONVERT_NOSPACE; break; } unsigned short prev = ch; if (flags & TCL_ENCODING_LE) { ch = (src[1] & 0xFF) << 8 | (src[0] & 0xFF); } else { ch = (src[0] & 0xFF) << 8 | (src[1] & 0xFF); } if (HIGH_SURROGATE(prev) && !LOW_SURROGATE(ch)) { if (PROFILE_STRICT(flags)) { result = TCL_CONVERT_SYNTAX; src -= 2; /* Go back to beginning of high surrogate */ dst--; /* Also undo writing a single byte too much */ numChars--; break; } else if (PROFILE_REPLACE(flags)) { /* * Previous loop wrote a single byte to mark the high surrogate. * Replace it with the replacement character. Further, restart * current loop iteration since need to recheck destination * space and reset processing of current character. */ ch = UNICODE_REPLACE_CHAR; dst--; dst += Tcl_UniCharToUtf(ch, dst); src -= 2; numChars--; continue; } else { /* * Bug [10c2c17c32]. If Hi surrogate not followed by Lo * surrogate, finish 3-byte UTF-8 */ dst += Tcl_UniCharToUtf(-1, dst); } } /* * Special case for 1-byte utf chars for speed. Make sure we work with * unsigned short-size data. |
︙ | ︙ | |||
2991 2992 2993 2994 2995 2996 2997 | * None. * *------------------------------------------------------------------------- */ static int UtfToUtf16Proc( | | | 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 | * None. * *------------------------------------------------------------------------- */ static int UtfToUtf16Proc( void *clientData, /* additional flags, e.g. TCL_ENCODING_LE */ const char *src, /* Source string in UTF-8. */ int srcLen, /* Source string length in bytes. */ int flags, /* Conversion control flags. */ TCL_UNUSED(Tcl_EncodingState *), char *dst, /* Output buffer in which converted string is * stored. */ int dstLen, /* The maximum length of output buffer in |
︙ | ︙ | |||
3099 3100 3101 3102 3103 3104 3105 | * None. * *------------------------------------------------------------------------- */ static int UtfToUcs2Proc( | | | 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 | * None. * *------------------------------------------------------------------------- */ static int UtfToUcs2Proc( void *clientData, /* additional flags, e.g. TCL_ENCODING_LE */ const char *src, /* Source string in UTF-8. */ int srcLen, /* Source string length in bytes. */ int flags, /* Conversion control flags. */ TCL_UNUSED(Tcl_EncodingState *), char *dst, /* Output buffer in which converted string is * stored. */ int dstLen, /* The maximum length of output buffer in |
︙ | ︙ | |||
3203 3204 3205 3206 3207 3208 3209 | * None. * *------------------------------------------------------------------------- */ static int TableToUtfProc( | | | 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 | * None. * *------------------------------------------------------------------------- */ static int TableToUtfProc( void *clientData, /* TableEncodingData that specifies * encoding. */ const char *src, /* Source string in specified encoding. */ int srcLen, /* Source string length in bytes. */ int flags, /* Conversion control flags. */ TCL_UNUSED(Tcl_EncodingState *), char *dst, /* Output buffer in which converted string is * stored. */ |
︙ | ︙ | |||
3266 3267 3268 3269 3270 3271 3272 | break; } else if (PROFILE_STRICT(flags)) { result = TCL_CONVERT_SYNTAX; break; } else if (PROFILE_REPLACE(flags)) { ch = UNICODE_REPLACE_CHAR; } else { | | > | 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 | break; } else if (PROFILE_STRICT(flags)) { result = TCL_CONVERT_SYNTAX; break; } else if (PROFILE_REPLACE(flags)) { ch = UNICODE_REPLACE_CHAR; } else { /* For prefix bytes, we don't fallback to cp1252, see * [1355b9a874] */ ch = byte; } } else { ch = toUnicode[byte][*((unsigned char *)++src)]; } } else { ch = pageZero[byte]; |
︙ | ︙ | |||
3331 3332 3333 3334 3335 3336 3337 | * None. * *------------------------------------------------------------------------- */ static int TableFromUtfProc( | | | 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 | * None. * *------------------------------------------------------------------------- */ static int TableFromUtfProc( void *clientData, /* TableEncodingData that specifies * encoding. */ const char *src, /* Source string in UTF-8. */ int srcLen, /* Source string length in bytes. */ int flags, /* Conversion control flags. */ TCL_UNUSED(Tcl_EncodingState *), char *dst, /* Output buffer in which converted string is * stored. */ |
︙ | ︙ | |||
3623 3624 3625 3626 3627 3628 3629 | * Memory freed. * *--------------------------------------------------------------------------- */ static void TableFreeProc( | | | 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 3658 3659 | * Memory freed. * *--------------------------------------------------------------------------- */ static void TableFreeProc( void *clientData) /* TableEncodingData that specifies * encoding. */ { TableEncodingData *dataPtr = (TableEncodingData *)clientData; /* * Make sure we aren't freeing twice on shutdown. [Bug 219314] */ |
︙ | ︙ | |||
3658 3659 3660 3661 3662 3663 3664 | * None. * *------------------------------------------------------------------------- */ static int EscapeToUtfProc( | | | 3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 | * None. * *------------------------------------------------------------------------- */ static int EscapeToUtfProc( void *clientData, /* EscapeEncodingData that specifies * encoding. */ const char *src, /* Source string in specified encoding. */ int srcLen, /* Source string length in bytes. */ int flags, /* Conversion control flags. */ Tcl_EncodingState *statePtr,/* Place for conversion routine to store state * information used during a piecewise * conversion. Contents of statePtr are |
︙ | ︙ | |||
3871 3872 3873 3874 3875 3876 3877 | * None. * *------------------------------------------------------------------------- */ static int EscapeFromUtfProc( | | | 3893 3894 3895 3896 3897 3898 3899 3900 3901 3902 3903 3904 3905 3906 3907 | * None. * *------------------------------------------------------------------------- */ static int EscapeFromUtfProc( void *clientData, /* EscapeEncodingData that specifies * encoding. */ const char *src, /* Source string in UTF-8. */ int srcLen, /* Source string length in bytes. */ int flags, /* Conversion control flags. */ Tcl_EncodingState *statePtr,/* Place for conversion routine to store state * information used during a piecewise * conversion. Contents of statePtr are |
︙ | ︙ | |||
3938 3939 3940 3941 3942 3943 3944 | memcpy(dst, dataPtr->init, dataPtr->initLen); dst += dataPtr->initLen; } else { state = PTR2INT(*statePtr); } encodingPtr = GetTableEncoding(dataPtr, state); | | | 3960 3961 3962 3963 3964 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 | memcpy(dst, dataPtr->init, dataPtr->initLen); dst += dataPtr->initLen; } else { state = PTR2INT(*statePtr); } encodingPtr = GetTableEncoding(dataPtr, state); tableDataPtr = (TableEncodingData *) encodingPtr->clientData; tablePrefixBytes = tableDataPtr->prefixBytes; tableFromUnicode = (const unsigned short *const *) tableDataPtr->fromUnicode; for (numChars = 0; src < srcEnd; numChars++) { unsigned len; int word; |
︙ | ︙ | |||
3966 3967 3968 3969 3970 3971 3972 | if ((word == 0) && (ch != 0)) { int oldState; const EscapeSubTable *subTablePtr; oldState = state; for (state = 0; state < dataPtr->numSubTables; state++) { encodingPtr = GetTableEncoding(dataPtr, state); | | | | 3988 3989 3990 3991 3992 3993 3994 3995 3996 3997 3998 3999 4000 4001 4002 4003 4004 4005 4006 4007 4008 4009 4010 4011 4012 4013 4014 4015 4016 | if ((word == 0) && (ch != 0)) { int oldState; const EscapeSubTable *subTablePtr; oldState = state; for (state = 0; state < dataPtr->numSubTables; state++) { encodingPtr = GetTableEncoding(dataPtr, state); tableDataPtr = (TableEncodingData *) encodingPtr->clientData; word = tableDataPtr->fromUnicode[(ch >> 8)][ch & 0xFF]; if (word != 0) { break; } } if (word == 0) { state = oldState; if (PROFILE_STRICT(flags)) { result = TCL_CONVERT_UNKNOWN; break; } encodingPtr = GetTableEncoding(dataPtr, state); tableDataPtr = (TableEncodingData *) encodingPtr->clientData; word = tableDataPtr->fallback; } tablePrefixBytes = (const char *) tableDataPtr->prefixBytes; tableFromUnicode = (const unsigned short *const *) tableDataPtr->fromUnicode; |
︙ | ︙ | |||
4082 4083 4084 4085 4086 4087 4088 | * Memory is freed. * *--------------------------------------------------------------------------- */ static void EscapeFreeProc( | | | 4104 4105 4106 4107 4108 4109 4110 4111 4112 4113 4114 4115 4116 4117 4118 | * Memory is freed. * *--------------------------------------------------------------------------- */ static void EscapeFreeProc( void *clientData) /* EscapeEncodingData that specifies * encoding. */ { EscapeEncodingData *dataPtr = (EscapeEncodingData *)clientData; EscapeSubTable *subTablePtr; int i; if (dataPtr == NULL) { |
︙ | ︙ | |||
4304 4305 4306 4307 4308 4309 4310 | } if (interp) { /* This code assumes at least two profiles :-) */ Tcl_Obj *errorObj = Tcl_ObjPrintf("bad profile name \"%s\": must be", profileName); for (i = 0; i < (numProfiles - 1); ++i) { Tcl_AppendStringsToObj( | | > | > | > | 4326 4327 4328 4329 4330 4331 4332 4333 4334 4335 4336 4337 4338 4339 4340 4341 4342 4343 4344 4345 4346 4347 4348 4349 4350 | } if (interp) { /* This code assumes at least two profiles :-) */ Tcl_Obj *errorObj = Tcl_ObjPrintf("bad profile name \"%s\": must be", profileName); for (i = 0; i < (numProfiles - 1); ++i) { Tcl_AppendStringsToObj( errorObj, " ", encodingProfiles[i].name, ",", (void *)NULL); } Tcl_AppendStringsToObj( errorObj, " or ", encodingProfiles[numProfiles-1].name, (void *)NULL); Tcl_SetObjResult(interp, errorObj); Tcl_SetErrorCode( interp, "TCL", "ENCODING", "PROFILE", profileName, (void *)NULL); } return TCL_ERROR; } /* *------------------------------------------------------------------------ * |
︙ | ︙ | |||
4338 4339 4340 4341 4342 4343 4344 | const char * TclEncodingProfileIdToName( Tcl_Interp *interp, /* For error messages. May be NULL */ int profileValue) /* Profile #define value */ { size_t i; | | > | | 4363 4364 4365 4366 4367 4368 4369 4370 4371 4372 4373 4374 4375 4376 4377 4378 4379 4380 4381 4382 4383 4384 4385 4386 4387 4388 | const char * TclEncodingProfileIdToName( Tcl_Interp *interp, /* For error messages. May be NULL */ int profileValue) /* Profile #define value */ { size_t i; for (i = 0; i < sizeof(encodingProfiles) / sizeof(encodingProfiles[0]); ++i) { if (profileValue == encodingProfiles[i].value) { return encodingProfiles[i].name; } } if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "Internal error. Bad profile id \"%d\".", profileValue)); Tcl_SetErrorCode( interp, "TCL", "ENCODING", "PROFILEID", (void *)NULL); } return NULL; } /* *------------------------------------------------------------------------ * |
︙ | ︙ | |||
4377 4378 4379 4380 4381 4382 4383 | Tcl_Interp *interp) { size_t i, n; Tcl_Obj *objPtr; n = sizeof(encodingProfiles) / sizeof(encodingProfiles[0]); objPtr = Tcl_NewListObj(n, NULL); for (i = 0; i < n; ++i) { | | | | | 4403 4404 4405 4406 4407 4408 4409 4410 4411 4412 4413 4414 4415 4416 4417 4418 4419 4420 4421 4422 | Tcl_Interp *interp) { size_t i, n; Tcl_Obj *objPtr; n = sizeof(encodingProfiles) / sizeof(encodingProfiles[0]); objPtr = Tcl_NewListObj(n, NULL); for (i = 0; i < n; ++i) { Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(encodingProfiles[i].name, TCL_INDEX_NONE)); } Tcl_SetObjResult(interp, objPtr); } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to generic/tclExecute.c.
︙ | ︙ | |||
655 656 657 658 659 660 661 | static Tcl_NRPostProc TEBCresume; /* * The structure below defines a bytecode Tcl object type to hold the * compiled bytecode for Tcl expressions. */ | | | 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 | static Tcl_NRPostProc TEBCresume; /* * The structure below defines a bytecode Tcl object type to hold the * compiled bytecode for Tcl expressions. */ const Tcl_ObjType tclExprCodeType = { "exprcode", FreeExprCodeInternalRep, /* freeIntRepProc */ DupExprCodeInternalRep, /* dupIntRepProc */ NULL, /* updateStringProc */ NULL, /* setFromAnyProc */ TCL_OBJTYPE_V0 }; |
︙ | ︙ | |||
1413 1414 1415 1416 1417 1418 1419 | * to avoid compiler warning. */ /* * Get the expression ByteCode from the object. If it exists, make sure it * is valid in the current context. */ | | | | 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 | * to avoid compiler warning. */ /* * Get the expression ByteCode from the object. If it exists, make sure it * is valid in the current context. */ ByteCodeGetInternalRep(objPtr, &tclExprCodeType, codePtr); if (codePtr != NULL) { Namespace *namespacePtr = iPtr->varFramePtr->nsPtr; if (((Interp *) *codePtr->interpHandle != iPtr) || (codePtr->compileEpoch != iPtr->compileEpoch) || (codePtr->nsPtr != namespacePtr) || (codePtr->nsEpoch != namespacePtr->resolverEpoch) || (codePtr->localCachePtr != iPtr->varFramePtr->localCachePtr)) { Tcl_StoreInternalRep(objPtr, &tclExprCodeType, NULL); codePtr = NULL; } } if (codePtr == NULL) { /* * TIP #280: No invoker (yet) - Expression compilation. |
︙ | ︙ | |||
1456 1457 1458 1459 1460 1461 1462 | /* * Add a "done" instruction as the last instruction and change the * object into a ByteCode object. Ownership of the literal objects and * aux data items is given to the ByteCode object. */ TclEmitOpcode(INST_DONE, &compEnv); | | | 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 | /* * Add a "done" instruction as the last instruction and change the * object into a ByteCode object. Ownership of the literal objects and * aux data items is given to the ByteCode object. */ TclEmitOpcode(INST_DONE, &compEnv); codePtr = TclInitByteCodeObj(objPtr, &tclExprCodeType, &compEnv); TclFreeCompileEnv(&compEnv); if (iPtr->varFramePtr->localCachePtr) { codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr; codePtr->localCachePtr->refCount++; } TclDebugPrintByteCodeObj(objPtr); } |
︙ | ︙ | |||
1525 1526 1527 1528 1529 1530 1531 | */ static void FreeExprCodeInternalRep( Tcl_Obj *objPtr) { ByteCode *codePtr; | | | 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 | */ static void FreeExprCodeInternalRep( Tcl_Obj *objPtr) { ByteCode *codePtr; ByteCodeGetInternalRep(objPtr, &tclExprCodeType, codePtr); assert(codePtr != NULL); TclReleaseByteCode(codePtr); } /* *---------------------------------------------------------------------- |
︙ | ︙ |
Changes to generic/tclInt.h.
︙ | ︙ | |||
3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 | * Variables denoting the Tcl object types defined in the core. */ MODULE_SCOPE const Tcl_ObjType tclBignumType; MODULE_SCOPE const Tcl_ObjType tclBooleanType; MODULE_SCOPE const Tcl_ObjType tclByteCodeType; MODULE_SCOPE const Tcl_ObjType tclDoubleType; MODULE_SCOPE const Tcl_ObjType tclIntType; MODULE_SCOPE const Tcl_ObjType tclIndexType; MODULE_SCOPE const Tcl_ObjType tclListType; MODULE_SCOPE const Tcl_ObjType tclDictType; MODULE_SCOPE const Tcl_ObjType tclProcBodyType; MODULE_SCOPE const Tcl_ObjType tclStringType; MODULE_SCOPE const Tcl_ObjType tclEnsembleCmdType; | > | 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 | * Variables denoting the Tcl object types defined in the core. */ MODULE_SCOPE const Tcl_ObjType tclBignumType; MODULE_SCOPE const Tcl_ObjType tclBooleanType; MODULE_SCOPE const Tcl_ObjType tclByteCodeType; MODULE_SCOPE const Tcl_ObjType tclDoubleType; MODULE_SCOPE const Tcl_ObjType tclExprCodeType; MODULE_SCOPE const Tcl_ObjType tclIntType; MODULE_SCOPE const Tcl_ObjType tclIndexType; MODULE_SCOPE const Tcl_ObjType tclListType; MODULE_SCOPE const Tcl_ObjType tclDictType; MODULE_SCOPE const Tcl_ObjType tclProcBodyType; MODULE_SCOPE const Tcl_ObjType tclStringType; MODULE_SCOPE const Tcl_ObjType tclEnsembleCmdType; |
︙ | ︙ | |||
3489 3490 3491 3492 3493 3494 3495 | MODULE_SCOPE int TclProcessReturn(Tcl_Interp *interp, int code, int level, Tcl_Obj *returnOpts); MODULE_SCOPE void TclUndoRefCount(Tcl_Obj *objPtr); MODULE_SCOPE int TclpObjLstat(Tcl_Obj *pathPtr, Tcl_StatBuf *buf); MODULE_SCOPE Tcl_Obj * TclpTempFileName(void); MODULE_SCOPE Tcl_Obj * TclpTempFileNameForLibrary(Tcl_Interp *interp, Tcl_Obj* pathPtr); | | < | 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 | MODULE_SCOPE int TclProcessReturn(Tcl_Interp *interp, int code, int level, Tcl_Obj *returnOpts); MODULE_SCOPE void TclUndoRefCount(Tcl_Obj *objPtr); MODULE_SCOPE int TclpObjLstat(Tcl_Obj *pathPtr, Tcl_StatBuf *buf); MODULE_SCOPE Tcl_Obj * TclpTempFileName(void); MODULE_SCOPE Tcl_Obj * TclpTempFileNameForLibrary(Tcl_Interp *interp, Tcl_Obj* pathPtr); MODULE_SCOPE Tcl_Obj * TclNewArithSeriesObj(Tcl_Interp *interp, int useDoubles, Tcl_Obj *startObj, Tcl_Obj *endObj, Tcl_Obj *stepObj, Tcl_Obj *lenObj); MODULE_SCOPE Tcl_Obj * TclNewFSPathObj(Tcl_Obj *dirPtr, const char *addStrRep, Tcl_Size len); MODULE_SCOPE void TclpAlertNotifier(void *clientData); MODULE_SCOPE void * TclpNotifierData(void); MODULE_SCOPE void TclpServiceModeHook(int mode); |
︙ | ︙ |
Changes to generic/tclListObj.c.
︙ | ︙ | |||
494 495 496 497 498 499 500 | *------------------------------------------------------------------------ */ static int ListLimitExceededError( Tcl_Interp *interp) { if (interp != NULL) { | | < | | 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 | *------------------------------------------------------------------------ */ static int ListLimitExceededError( Tcl_Interp *interp) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "max length of a Tcl list exceeded", -1)); Tcl_SetErrorCode(interp, "TCL", "MEMORY", (char *)NULL); } return TCL_ERROR; } /* *------------------------------------------------------------------------ |
︙ | ︙ |
Changes to generic/tclScan.c.
︙ | ︙ | |||
354 355 356 357 358 359 360 | * Parse any width specifier. */ if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */ /* Note ull >= 0 because of isdigit check above */ unsigned long long ull; ull = strtoull( | | | < | | < | | | 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 | * Parse any width specifier. */ if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */ /* Note ull >= 0 because of isdigit check above */ unsigned long long ull; ull = strtoull( format - 1, (char **)&format, 10); /* INTL: "C" locale. */ /* Note >=, not >, to leave room for a nul */ if (ull >= TCL_SIZE_MAX) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "specified field width %" TCL_LL_MODIFIER "u exceeds limit %" TCL_SIZE_MODIFIER "d.", ull, (Tcl_Size)TCL_SIZE_MAX-1)); Tcl_SetErrorCode( interp, "TCL", "FORMAT", "WIDTHLIMIT", (char *)NULL); goto error; } flags |= SCAN_WIDTH; format += TclUtfToUniChar(format, &ch); } /* |
︙ | ︙ |
Changes to library/history.tcl.
︙ | ︙ | |||
193 194 195 196 197 198 199 | set result {} set newline "" for {set i [expr {$history(nextid) - $count + 1}]} \ {$i <= $history(nextid)} {incr i} { if {![info exists history($i)]} { continue } | | | 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 | set result {} set newline "" for {set i [expr {$history(nextid) - $count + 1}]} \ {$i <= $history(nextid)} {incr i} { if {![info exists history($i)]} { continue } set cmd [string map [list \n \n\t] [string trimright $history($i) \ \n]] append result $newline[format "%6d %s" $i $cmd] set newline \n } return $result } # tcl::HistRedo -- |
︙ | ︙ |
Changes to library/http/http.tcl.
︙ | ︙ | |||
153 154 155 156 157 158 159 | )? } variable TmpSockCounter 0 variable ThreadCounter 0 variable reasonDict [dict create {*}{ | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 | )? } variable TmpSockCounter 0 variable ThreadCounter 0 variable reasonDict [dict create {*}{ 100 Continue 101 {Switching Protocols} 102 Processing 103 {Early Hints} 200 OK 201 Created 202 Accepted 203 {Non-Authoritative Information} 204 {No Content} 205 {Reset Content} 206 {Partial Content} 207 Multi-Status 208 {Already Reported} 226 {IM Used} 300 {Multiple Choices} 301 {Moved Permanently} 302 Found 303 {See Other} 304 {Not Modified} 305 {Use Proxy} 306 (Unused) 307 {Temporary Redirect} 308 {Permanent Redirect} 400 {Bad Request} 401 Unauthorized 402 {Payment Required} 403 Forbidden 404 {Not Found} 405 {Method Not Allowed} 406 {Not Acceptable} 407 {Proxy Authentication Required} 408 {Request Timeout} 409 Conflict 410 Gone 411 {Length Required} 412 {Precondition Failed} 413 {Content Too Large} 414 {URI Too Long} 415 {Unsupported Media Type} 416 {Range Not Satisfiable} 417 {Expectation Failed} 418 (Unused) 421 {Misdirected Request} 422 {Unprocessable Content} 423 Locked 424 {Failed Dependency} 425 {Too Early} 426 {Upgrade Required} 428 {Precondition Required} 429 {Too Many Requests} 431 {Request Header Fields Too Large} 451 {Unavailable For Legal Reasons} 500 {Internal Server Error} 501 {Not Implemented} 502 {Bad Gateway} 503 {Service Unavailable} 504 {Gateway Timeout} 505 {HTTP Version Not Supported} 506 {Variant Also Negotiates} 507 {Insufficient Storage} 508 {Loop Detected} 510 {Not Extended (OBSOLETED)} 511 {Network Authentication Required} }] variable failedProxyValues { binary body charset coding |
︙ | ︙ | |||
295 296 297 298 299 300 301 | # list of port, command, variable name, (boolean) threadability, # and (boolean) endToEndProxy that was registered. proc http::register {proto port command {socketCmdVarName {}} {useSockThread 0} {endToEndProxy 0}} { variable urlTypes set lower [string tolower $proto] if {[info exists urlTypes($lower)]} { | | | 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 | # list of port, command, variable name, (boolean) threadability, # and (boolean) endToEndProxy that was registered. proc http::register {proto port command {socketCmdVarName {}} {useSockThread 0} {endToEndProxy 0}} { variable urlTypes set lower [string tolower $proto] if {[info exists urlTypes($lower)]} { unregister $lower } set urlTypes($lower) [list $port $command $socketCmdVarName $useSockThread $endToEndProxy] # If the external handler for protocol $proto has given $socketCmdVarName the expected # value "::socket", overwrite it with the new value. if {($socketCmdVarName ne {}) && ([set $socketCmdVarName] eq {::socket})} { set $socketCmdVarName ::http::socketAsCallback |
︙ | ︙ | |||
343 344 345 346 347 348 349 | # http::config -- # # See documentation for details. # # Arguments: # args Options parsed by the procedure. # Results: | | | 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 | # http::config -- # # See documentation for details. # # Arguments: # args Options parsed by the procedure. # Results: # TODO proc http::config {args} { variable http set options [lsort [array names http -*]] set usage [join $options ", "] if {[llength $args] == 0} { set result {} |
︙ | ︙ | |||
397 398 399 400 401 402 403 | # # Return Value: the reason phrase # ------------------------------------------------------------------------------ proc http::reasonPhrase {code} { variable reasonDict if {![regexp -- {^[1-5][0-9][0-9]$} $code]} { | | | | | | | 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 | # # Return Value: the reason phrase # ------------------------------------------------------------------------------ proc http::reasonPhrase {code} { variable reasonDict if {![regexp -- {^[1-5][0-9][0-9]$} $code]} { set msg {argument must be a three-digit integer from 100 to 599} return -code error $msg } if {[dict exists $reasonDict $code]} { set reason [dict get $reasonDict $code] } else { set reason Unassigned } return $reason } # http::Finish -- # # Clean up the socket and eval close time callbacks # # Arguments: # token Connection token. # errormsg (optional) If set, forces status to error. # skipCB (optional) If set, don't call the -command callback. This # is useful when geturl wants to throw an exception instead # of calling the callback. That way, the same error isn't # reported to two places. # # Side Effects: # May close the socket. proc http::Finish {token {errormsg ""} {skipCB 0}} { variable socketMapping variable socketRdState variable socketWrState variable socketRdQueue variable socketWrQueue |
︙ | ︙ | |||
450 451 452 453 454 455 456 | if {[info commands ${token}--EventCoroutine] ne {}} { rename ${token}--EventCoroutine {} } if {[info commands ${token}--SocketCoroutine] ne {}} { rename ${token}--SocketCoroutine {} } if {[info exists state(socketcoro)]} { | | | | | 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 | if {[info commands ${token}--EventCoroutine] ne {}} { rename ${token}--EventCoroutine {} } if {[info commands ${token}--SocketCoroutine] ne {}} { rename ${token}--SocketCoroutine {} } if {[info exists state(socketcoro)]} { Log $token Cancel socket after-idle event (Finish) after cancel $state(socketcoro) unset state(socketcoro) } # Is this an upgrade request/response? set upgradeResponse \ [expr { [info exists state(upgradeRequest)] && $state(upgradeRequest) && [info exists state(http)] |
︙ | ︙ | |||
477 478 479 480 481 482 483 | } { set closeQueue 1 set connId $state(socketinfo) if {[info exists state(sock)]} { set sock $state(sock) CloseSocket $state(sock) $token } else { | | | | | | | < | | | | | | 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 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 | } { set closeQueue 1 set connId $state(socketinfo) if {[info exists state(sock)]} { set sock $state(sock) CloseSocket $state(sock) $token } else { # When opening the socket and calling http::reset # immediately, the socket may not yet exist. # Test http-4.11 may come here. } if {$state(tid) ne {}} { # When opening the socket in a thread, and calling http::reset # immediately, the thread may still exist. # Test http-4.11 may come here. thread::release $state(tid) set state(tid) {} } else { } } elseif {$upgradeResponse} { # Special handling for an upgrade request/response. # - geturl ensures that this is not a "persistent" socket used for # multiple HTTP requests, so a call to KeepSocket is not needed. # - Leave socket open, so a call to CloseSocket is not needed either. # - Remove fileevent bindings. The caller will set its own bindings. # - THE CALLER MUST PROCESS THE UPGRADED SOCKET IN THE CALLBACK COMMAND # PASSED TO http::geturl AS -command callback. catch {fileevent $state(sock) readable {}} catch {fileevent $state(sock) writable {}} } elseif {([info exists state(-keepalive)] && !$state(-keepalive)) || ([info exists state(connection)] && ("close" in $state(connection))) } { set closeQueue 1 set connId $state(socketinfo) if {[info exists state(sock)]} { set sock $state(sock) CloseSocket $state(sock) $token } else { # When opening the socket and calling http::reset # immediately, the socket may not yet exist. # Test http-4.11 may come here. } } elseif { ([info exists state(-keepalive)] && $state(-keepalive)) && ([info exists state(connection)] && ("close" ni $state(connection))) } { KeepSocket $token } |
︙ | ︙ | |||
917 918 919 920 921 922 923 | # See documentation for details. # # Arguments: # token Connection token. # why Status info. # # Side Effects: | | | 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 | # See documentation for details. # # Arguments: # token Connection token. # why Status info. # # Side Effects: # See Finish proc http::reset {token {why reset}} { variable $token upvar 0 $token state set state(status) $why catch {fileevent $state(sock) readable {}} catch {fileevent $state(sock) writable {}} |
︙ | ︙ | |||
1116 1117 1118 1119 1120 1121 1122 | set usage [join [lsort $options] ", "] set options [string map {- ""} $options] set pat ^-(?:[join $options |])$ foreach {flag value} $args { if {[regexp -- $pat $flag]} { # Validate numbers if { [info exists type($flag)] | | | 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 | set usage [join [lsort $options] ", "] set options [string map {- ""} $options] set pat ^-(?:[join $options |])$ foreach {flag value} $args { if {[regexp -- $pat $flag]} { # Validate numbers if { [info exists type($flag)] && (![string is $type($flag) -strict $value]) } { unset $token return -code error \ "Bad value for $flag ($value), must be $type($flag)" } if {($flag eq "-headers") && ([llength $value] % 2 != 0)} { unset $token |
︙ | ︙ | |||
1400 1401 1402 1403 1404 1405 1406 | # Pass -myaddr directly to the socket command if {[info exists state(-myaddr)]} { lappend sockopts -myaddr $state(-myaddr) } if {$useSockThread} { | | | | 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 | # Pass -myaddr directly to the socket command if {[info exists state(-myaddr)]} { lappend sockopts -myaddr $state(-myaddr) } if {$useSockThread} { set targs [list -type $token] } else { set targs {} } set state(connArgs) [list $proto $phost $srvurl] set state(openCmd) [list {*}$defcmd {*}$sockopts {*}$targs {*}$targetAddr] # See if we are supposed to use a previously opened channel. # - In principle, ANY call to http::geturl could use a previously opened # channel if it is available - the "Connection: keep-alive" header is a |
︙ | ︙ | |||
1503 1504 1505 1506 1507 1508 1509 | } } set state(reusing) $reusing unset reusing if {![info exists sock]} { | | | | 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 | } } set state(reusing) $reusing unset reusing if {![info exists sock]} { # N.B. At this point ([info exists sock] == $state(reusing)). # This will no longer be true after we set a value of sock here. # Give the socket a placeholder name. set sock HTTP_PLACEHOLDER_[incr TmpSockCounter] } set state(sock) $sock if {$state(reusing)} { # Define these for use (only) by http::ReplayIfDead if the persistent |
︙ | ︙ | |||
1601 1602 1603 1604 1605 1606 1607 | if { $state(-keepalive) && (![info exists socketMapping($state(socketinfo))]) } { # This code is executed only for the first -keepalive request on a # socket. It makes the socket persistent. ##Log " PreparePersistentConnection" $token -- $sock -- DO | | | | | | | | | | | | | | | | | | | | | | | | 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 | if { $state(-keepalive) && (![info exists socketMapping($state(socketinfo))]) } { # This code is executed only for the first -keepalive request on a # socket. It makes the socket persistent. ##Log " PreparePersistentConnection" $token -- $sock -- DO set DoLater [PreparePersistentConnection $token] } else { ##Log " PreparePersistentConnection" $token -- $sock -- SKIP set DoLater {-traceread 0 -tracewrite 0} } if {$state(ReusingPlaceholder)} { # - This request was added to the socketPhQueue of a persistent # connection. # - But the connection has not yet been created and is a placeholder; # - And the placeholder was created by an earlier request. # - When that earlier request calls OpenSocket, its placeholder is # replaced with a true socket, and it then executes the equivalent of # OpenSocket for any subsequent requests that have # $state(ReusingPlaceholder). Log >J$tk after idle coro NO - ReusingPlaceholder } elseif {$state(alreadyQueued)} { # - This request was added to the socketWrQueue and socketPlayCmd # of a persistent connection that will close at the end of its current # read operation. Log >J$tk after idle coro NO - alreadyQueued } else { Log >J$tk after idle coro YES set CoroName ${token}--SocketCoroutine set cancel [after idle [list coroutine $CoroName ::http::OpenSocket \ $token $DoLater]] dict set socketCoEvent($state(socketinfo)) $token $cancel set state(socketcoro) $cancel } return } # ------------------------------------------------------------------------------ |
︙ | ︙ | |||
1673 1674 1675 1676 1677 1678 1679 | set socketProxyId($state(socketinfo)) $state(proxyUsed) # - The value of state(proxyUsed) was set in http::CreateToken to either # "none" or "HttpProxy". # - $token is the first transaction to use this placeholder, so there are # no other tokens whose (proxyUsed) must be modified. if {![info exists socketRdState($state(socketinfo))]} { | | | | | | | | | | | | | | | | | | | | | | 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 | set socketProxyId($state(socketinfo)) $state(proxyUsed) # - The value of state(proxyUsed) was set in http::CreateToken to either # "none" or "HttpProxy". # - $token is the first transaction to use this placeholder, so there are # no other tokens whose (proxyUsed) must be modified. if {![info exists socketRdState($state(socketinfo))]} { set socketRdState($state(socketinfo)) {} # set varName ::http::socketRdState($state(socketinfo)) # trace add variable $varName unset ::http::CancelReadPipeline dict set DoLater -traceread 1 } if {![info exists socketWrState($state(socketinfo))]} { set socketWrState($state(socketinfo)) {} # set varName ::http::socketWrState($state(socketinfo)) # trace add variable $varName unset ::http::CancelWritePipeline dict set DoLater -tracewrite 1 } if {$state(-pipeline)} { #Log new, init for pipelined, GRANT write access to $token in geturl # Also grant premature read access to the socket. This is OK. set socketRdState($state(socketinfo)) $token set socketWrState($state(socketinfo)) $token } else { # socketWrState is not used by this non-pipelined transaction. # We cannot leave it as "Wready" because the next call to # http::geturl with a pipelined transaction would conclude that the # socket is available for writing. #Log new, init for nonpipeline, GRANT r/w access to $token in geturl set socketRdState($state(socketinfo)) $token set socketWrState($state(socketinfo)) $token } # Value of socketPhQueue() may have already been set by ReplayCore. if {![info exists socketPhQueue($state(sock))]} { set socketPhQueue($state(sock)) {} } set socketRdQueue($state(socketinfo)) {} set socketWrQueue($state(socketinfo)) {} set socketClosing($state(socketinfo)) 0 set socketPlayCmd($state(socketinfo)) {ReplayIfClose Wready {} {}} set socketCoEvent($state(socketinfo)) {} set socketProxyId($state(socketinfo)) {} |
︙ | ︙ | |||
1747 1748 1749 1750 1751 1752 1753 | variable socketPlayCmd variable socketCoEvent variable socketProxyId Log >K$tk Start OpenSocket coroutine if {![info exists state(-keepalive)]} { | | | | | | | 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 | variable socketPlayCmd variable socketCoEvent variable socketProxyId Log >K$tk Start OpenSocket coroutine if {![info exists state(-keepalive)]} { # The request has already been cancelled by the calling script. return } set sockOld $state(sock) dict unset socketCoEvent($state(socketinfo)) $token unset -nocomplain state(socketcoro) if {[catch { if {$state(reusing)} { # If ($state(reusing)) is true, then we do not need to create a new # socket, even if $sockOld is only a placeholder for a socket. set sock $sockOld } else { # set sock in the [catch] below. set pre [clock milliseconds] ##Log pre socket opened, - token $token ##Log $state(openCmd) - token $token set sock [namespace eval :: $state(openCmd)] set state(sock) $sock # Normal return from $state(openCmd) always returns a valid socket. |
︙ | ︙ | |||
1785 1786 1787 1788 1789 1790 1791 | } fconfigure $sock -translation {auto crlf} \ -buffersize $state(-blocksize) if {[package vsatisfies [package provide Tcl] 9.0-]} { fconfigure $sock -profile replace } ##Log socket opened, DONE fconfigure - token $token | | | | | | | | 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 | } fconfigure $sock -translation {auto crlf} \ -buffersize $state(-blocksize) if {[package vsatisfies [package provide Tcl] 9.0-]} { fconfigure $sock -profile replace } ##Log socket opened, DONE fconfigure - token $token } Log "Using $sock for $state(socketinfo) - token $token" \ [expr {$state(-keepalive)?"keepalive":""}] # Code above has set state(sock) $sock ConfigureNewSocket $token $sockOld $DoLater ##Log OpenSocket success $sock - token $token } result errdict]} { ##Log OpenSocket failed $result - token $token # There may be other requests in the socketPhQueue. # Prepare socketPlayCmd so that Finish will replay them. if { ($state(-keepalive)) && (!$state(reusing)) && [info exists socketPhQueue($sockOld)] && ($socketPhQueue($sockOld) ne {}) } { if {$socketMapping($state(socketinfo)) ne $sockOld} { Log "WARNING: this code should not be reached.\ {$socketMapping($state(socketinfo)) ne $sockOld}" } set socketPlayCmd($state(socketinfo)) [list ReplayIfClose Wready {} $socketPhQueue($sockOld)] set socketPhQueue($sockOld) {} } if {[string range $result 0 20] eq {proxy connect failed:}} { # - The HTTPS proxy did not create a socket. The pre-existing value # (a "placeholder socket") is unchanged. # - The proxy returned a valid HTTP response to the failed CONNECT # request, and http::SecureProxyConnect copied this to $token, # and also set ${token}(connection) set to "close". # - Remove the error message $result so that Finish delivers this # HTTP response to the caller. |
︙ | ︙ | |||
1883 1884 1885 1886 1887 1888 1889 | set reusing $state(reusing) set sock $state(sock) set proxyUsed $state(proxyUsed) ##Log " ConfigureNewSocket" $token $sockOld ... -- $reusing $sock $proxyUsed if {(!$reusing) && ($sock ne $sockOld)} { | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 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 | set reusing $state(reusing) set sock $state(sock) set proxyUsed $state(proxyUsed) ##Log " ConfigureNewSocket" $token $sockOld ... -- $reusing $sock $proxyUsed if {(!$reusing) && ($sock ne $sockOld)} { # Replace the placeholder value sockOld with sock. if { [info exists socketMapping($state(socketinfo))] && ($socketMapping($state(socketinfo)) eq $sockOld) } { set socketMapping($state(socketinfo)) $sock set socketProxyId($state(socketinfo)) $proxyUsed # tokens that use the placeholder $sockOld are updated below. ##Log set socketMapping($state(socketinfo)) $sock } # Now finish any tasks left over from PreparePersistentConnection on # the connection. # # The "unset" traces are fired by init (clears entire arrays), and # by http::Unset. # Unset is called by CloseQueuedQueries and (possibly never) by geturl. # # CancelReadPipeline, CancelWritePipeline call http::Finish for each # token. # # FIXME If Finish is placeholder-aware, these traces can be set earlier, # in PreparePersistentConnection. if {[dict get $DoLater -traceread]} { set varName ::http::socketRdState($state(socketinfo)) trace add variable $varName unset ::http::CancelReadPipeline } if {[dict get $DoLater -tracewrite]} { set varName ::http::socketWrState($state(socketinfo)) trace add variable $varName unset ::http::CancelWritePipeline } } # Do this in all cases. ScheduleRequest $token # Now look at all other tokens that use the placeholder $sockOld. if { (!$reusing) && ($sock ne $sockOld) && [info exists socketPhQueue($sockOld)] } { ##Log " ConfigureNewSocket" $token scheduled, now do $socketPhQueue($sockOld) foreach tok $socketPhQueue($sockOld) { # 1. Amend the token's (sock). ##Log set ${tok}(sock) $sock set ${tok}(sock) $sock set ${tok}(proxyUsed) $proxyUsed # 2. Schedule the token's HTTP request. # Every token in socketPhQueue(*) has reusing 1 alreadyQueued 0. |
︙ | ︙ | |||
2081 2082 2083 2084 2085 2086 2087 | # pipelined request jumping the queue. ##Log "HTTP request for token $token is queued for nonpipeline use" #Log re-use nonpipeline, GRANT delayed write access to $token in geturl set socketWrState($state(socketinfo)) peNding lappend socketWrQueue($state(socketinfo)) $token } else { | | | | | | | | | | | 2080 2081 2082 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 2120 2121 2122 2123 2124 | # pipelined request jumping the queue. ##Log "HTTP request for token $token is queued for nonpipeline use" #Log re-use nonpipeline, GRANT delayed write access to $token in geturl set socketWrState($state(socketinfo)) peNding lappend socketWrQueue($state(socketinfo)) $token } else { if {$reusing && $state(-pipeline)} { #Log new, init for pipelined, GRANT write access to $token in geturl # DO NOT grant premature read access to the socket. # set socketRdState($state(socketinfo)) $token set socketWrState($state(socketinfo)) $token } elseif {$reusing} { # socketWrState is not used by this non-pipelined transaction. # We cannot leave it as "Wready" because the next call to # http::geturl with a pipelined transaction would conclude that the # socket is available for writing. #Log new, init for nonpipeline, GRANT r/w access to $token in geturl set socketRdState($state(socketinfo)) $token set socketWrState($state(socketinfo)) $token } else { } # Process the request now. # - Command is not called unless $state(sock) is a real socket handle # and not a placeholder. # - All (!$reusing) cases come here. # - Some $reusing cases come here too if the connection is # marked as ready. Those $reusing cases are: # $reusing && ($socketWrState($state(socketinfo)) eq "Wready") && # EITHER !$pipeline && ($socketRdState($state(socketinfo)) eq "Rready") # OR $pipeline # #Log ---- $state(socketinfo) << conn to $token for HTTP request (a) ##Log " ScheduleRequest" $token -- fileevent $state(sock) writable for $token # Connect does its own fconfigure. lassign $state(connArgs) proto phost srvurl if {[catch { fileevent $state(sock) writable \ [list http::Connect $token $proto $phost $srvurl] } res opts]} { # The socket no longer exists. ##Log bug -- socket gone -- $res -- $opts |
︙ | ︙ | |||
2280 2281 2282 2283 2284 2285 2286 | # Some server implementations of HTTP/1.0 have a faulty # implementation of RFC 2068 Keep-Alive. # Don't leave this to chance. # For HTTP/1.0 we have already "set state(connection) close" # and "state(-keepalive) 0". set ConnVal close } | | | | | | 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 | # Some server implementations of HTTP/1.0 have a faulty # implementation of RFC 2068 Keep-Alive. # Don't leave this to chance. # For HTTP/1.0 we have already "set state(connection) close" # and "state(-keepalive) 0". set ConnVal close } # Proxy authorisation (cf. mod by Anders Ramdahl to autoproxy by # Pat Thoyts). if {($http(-proxyauth) ne {}) && ($state(proxyUsed) eq {HttpProxy})} { SendHeader $token Proxy-Authorization $http(-proxyauth) } # RFC7230 A.1 - "clients are encouraged not to send the # Proxy-Connection header field in any requests" set accept_encoding_seen 0 set content_type_seen 0 set connection_seen 0 foreach {key value} $state(-headers) { set value [string map [list \n "" \r ""] $value] |
︙ | ︙ | |||
2310 2311 2312 2313 2314 2315 2316 | set content_type_seen 1 } if {[string equal -nocase $key "content-length"]} { set contDone 1 set state(querylength) $value } if { [string equal -nocase $key "connection"] | | | 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 | set content_type_seen 1 } if {[string equal -nocase $key "content-length"]} { set contDone 1 set state(querylength) $value } if { [string equal -nocase $key "connection"] && [info exists state(bypass)] } { # Value supplied in -headers overrides $ConnVal. set connection_seen 1 } elseif {[string equal -nocase $key "connection"]} { # Remove "close" or "keep-alive" and use our own value. # In an upgrade request, the upgrade is not guaranteed. # Value "close" or "keep-alive" tells the server what to do |
︙ | ︙ | |||
2602 2603 2604 2605 2606 2607 2608 | if {[package vsatisfies [package provide Tcl] 9.0-]} { fconfigure $sock -profile replace } Log ^D$tk begin receiving response - token $token coroutine ${token}--EventCoroutine http::Event $sock $token if {[info exists state(-handler)] || [info exists state(-progress)]} { | | | | 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 | if {[package vsatisfies [package provide Tcl] 9.0-]} { fconfigure $sock -profile replace } Log ^D$tk begin receiving response - token $token coroutine ${token}--EventCoroutine http::Event $sock $token if {[info exists state(-handler)] || [info exists state(-progress)]} { fileevent $sock readable [list http::EventGateway $sock $token] } else { fileevent $sock readable ${token}--EventCoroutine } return } # http::EventGateway # |
︙ | ︙ | |||
2630 2631 2632 2633 2634 2635 2636 | proc http::EventGateway {sock token} { variable $token upvar 0 $token state fileevent $sock readable {} catch {${token}--EventCoroutine} res opts if {[info commands ${token}--EventCoroutine] ne {}} { | | | | | | | | | | | 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 | proc http::EventGateway {sock token} { variable $token upvar 0 $token state fileevent $sock readable {} catch {${token}--EventCoroutine} res opts if {[info commands ${token}--EventCoroutine] ne {}} { # The coroutine can be deleted by completion (a non-yield return), by # http::Finish (when there is a premature end to the transaction), by # http::reset or http::cleanup, or if the caller set option -channel # but not option -handler: in the last case reading from the socket is # now managed by commands ::http::Copy*, http::ReceiveChunked, and # http::MakeTransformationChunked. # # Catch in case the coroutine has closed the socket. catch {fileevent $sock readable [list http::EventGateway $sock $token]} } # If there was an error, re-throw it. return -options $opts $res } |
︙ | ︙ | |||
3044 3045 3046 3047 3048 3049 3050 | } if {[info exists state(after)]} { after cancel $state(after) unset state(after) } if {[info exists state(socketcoro)]} { | | | | | 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 | } if {[info exists state(after)]} { after cancel $state(after) unset state(after) } if {[info exists state(socketcoro)]} { Log $token Cancel socket after-idle event (ReInit) after cancel $state(socketcoro) unset state(socketcoro) } # Don't alter state(status) - this would trigger http::wait if it is in use. set tmpState $state(tmpState) set tmpOpenCmd $state(tmpOpenCmd) set tmpConnArgs $state(tmpConnArgs) foreach name [array names state] { |
︙ | ︙ | |||
3206 3207 3208 3209 3210 3211 3212 | variable $token upvar 0 $token state return $state(currentsize) } proc http::requestHeaders {token args} { set lenny [llength $args] if {$lenny > 1} { | | | | | | | | | | | | | | | | | | | | | | | | 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 | variable $token upvar 0 $token state return $state(currentsize) } proc http::requestHeaders {token args} { set lenny [llength $args] if {$lenny > 1} { return -code error {usage: ::http::requestHeaders token ?headerName?} } else { return [Meta $token request {*}$args] } } proc http::responseHeaders {token args} { set lenny [llength $args] if {$lenny > 1} { return -code error {usage: ::http::responseHeaders token ?headerName?} } else { return [Meta $token response {*}$args] } } proc http::requestHeaderValue {token header} { Meta $token request $header VALUE } proc http::responseHeaderValue {token header} { Meta $token response $header VALUE } proc http::Meta {token who args} { variable $token upvar 0 $token state if {$who eq {request}} { set whom requestHeaders } elseif {$who eq {response}} { set whom meta } else { return -code error {usage: ::http::Meta token request|response ?headerName ?VALUE??} } set header [string tolower [lindex $args 0]] set how [string tolower [lindex $args 1]] set lenny [llength $args] if {$lenny == 0} { return $state($whom) } elseif {($lenny > 2) || (($lenny == 2) && ($how ne {value}))} { return -code error {usage: ::http::Meta token request|response ?headerName ?VALUE??} } else { set result {} set combined {} foreach {key value} $state($whom) { if {$key eq $header} { lappend result $key $value append combined $value {, } } } if {$lenny == 1} { return $result } else { return [string range $combined 0 end-2] } } } # ------------------------------------------------------------------------------ # Proc http::responseInfo # ------------------------------------------------------------------------------ |
︙ | ︙ | |||
3279 3280 3281 3282 3283 3284 3285 | # ------------------------------------------------------------------------------ proc http::responseInfo {token} { variable $token upvar 0 $token state set result {} foreach {key origin name} { | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 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 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 | # ------------------------------------------------------------------------------ proc http::responseInfo {token} { variable $token upvar 0 $token state set result {} foreach {key origin name} { stage STATE state status STATE status responseCode STATE responseCode reasonPhrase STATE reasonPhrase contentType STATE type binary STATE binary redirection RESP location upgrade STATE upgrade error ERROR - postError STATE posterror method STATE method charset STATE charset compression STATE coding httpRequest STATE -protocol httpResponse STATE httpResponse url STATE url connectionRequest REQ connection connectionResponse RESP connection connectionActual STATE connection transferEncoding STATE transfer totalPost STATE querylength currentPost STATE queryoffset totalSize STATE totalsize currentSize STATE currentsize proxyUsed STATE proxyUsed } { if {$origin eq {STATE}} { if {[info exists state($name)]} { dict set result $key $state($name) } else { # Should never come here dict set result $key {} } } elseif {$origin eq {REQ}} { dict set result $key [requestHeaderValue $token $name] } elseif {$origin eq {RESP}} { dict set result $key [responseHeaderValue $token $name] } elseif {$origin eq {ERROR}} { # Don't flood the dict with data. The command ::http::error is # available. if {[info exists state(error)]} { set msg [lindex $state(error) 0] } else { set msg {} } dict set result $key $msg } else { # Should never come here dict set result $key {} } } return $result } proc http::error {token} { variable $token upvar 0 $token state if {[info exists state(error)]} { |
︙ | ︙ | |||
3373 3374 3375 3376 3377 3378 3379 | rename ${token}--SocketCoroutine {} } if {[info exists state(after)]} { after cancel $state(after) unset state(after) } if {[info exists state(socketcoro)]} { | | | | | 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 | rename ${token}--SocketCoroutine {} } if {[info exists state(after)]} { after cancel $state(after) unset state(after) } if {[info exists state(socketcoro)]} { Log $token Cancel socket after-idle event (cleanup) after cancel $state(socketcoro) unset state(socketcoro) } if {[info exists state]} { unset state } return } |
︙ | ︙ | |||
3400 3401 3402 3403 3404 3405 3406 | proc http::Connect {token proto phost srvurl} { variable $token upvar 0 $token state set tk [namespace tail $token] if {[catch {eof $state(sock)} tmp] || $tmp} { | | | | | 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 | proc http::Connect {token proto phost srvurl} { variable $token upvar 0 $token state set tk [namespace tail $token] if {[catch {eof $state(sock)} tmp] || $tmp} { set err "due to unexpected EOF" } elseif {[set err [fconfigure $state(sock) -error]] ne ""} { # set err is done in test } else { # All OK set state(state) connecting fileevent $state(sock) writable {} ::http::Connected $token $proto $phost $srvurl return } # Error cases. |
︙ | ︙ | |||
3817 3818 3819 3820 3821 3822 3823 | if {[info commands ${token}--EventCoroutine] ne {}} { rename ${token}--EventCoroutine {} } if {[info commands ${token}--SocketCoroutine] ne {}} { rename ${token}--SocketCoroutine {} } if {[info exists state(socketcoro)]} { | | | | | 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 3826 3827 3828 3829 3830 3831 3832 | if {[info commands ${token}--EventCoroutine] ne {}} { rename ${token}--EventCoroutine {} } if {[info commands ${token}--SocketCoroutine] ne {}} { rename ${token}--SocketCoroutine {} } if {[info exists state(socketcoro)]} { Log $token Cancel socket after-idle event (Finish) after cancel $state(socketcoro) unset state(socketcoro) } if {[info exists state(after)]} { after cancel $state(after) unset state(after) } if { [info exists state(-command)] && (![info exists state(done-command-cb)]) |
︙ | ︙ | |||
4643 4644 4645 4646 4647 4648 4649 | # ------------------------------------------------------------------------------ proc http::GuessType {token} { variable $token upvar 0 $token state if {$state(type) ne {application/octet-stream}} { | | | | | | | | | | 4642 4643 4644 4645 4646 4647 4648 4649 4650 4651 4652 4653 4654 4655 4656 4657 4658 4659 4660 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 | # ------------------------------------------------------------------------------ proc http::GuessType {token} { variable $token upvar 0 $token state if {$state(type) ne {application/octet-stream}} { return 0 } set body $state(body) # e.g. {<?xml version="1.0" encoding="utf-8"?> ...} if {![regexp -nocase -- {^<[?]xml[[:space:]][^>?]*[?]>} $body match]} { return 0 } # e.g. {<?xml version="1.0" encoding="utf-8"?>} set contents [regsub -- {[[:space:]]+} $match { }] set contents [string range [string tolower $contents] 6 end-2] # e.g. {version="1.0" encoding="utf-8"} # without excess whitespace or upper-case letters if {![regexp -- {^([^=" ]+="[^"]+" )+$} "$contents "]} { return 0 } # The application/xml default encoding: set res utf-8 set tagList [regexp -all -inline -- {[^=" ]+="[^"]+"} $contents] foreach tag $tagList { regexp -- {([^=" ]+)="([^"]+)"} $tag -> name value if {$name eq {encoding}} { set res $value } } set enc [CharsetToEncoding $res] if {$enc eq "binary"} { return 0 } if {[package vsatisfies [package provide Tcl] 9.0-]} { set state(body) [encoding convertfrom -profile replace $enc $state(body)] } else { set state(body) [encoding convertfrom $enc $state(body)] } set state(body) [string map {\r\n \n \r \n} $state(body)] |
︙ | ︙ | |||
4725 4726 4727 4728 4729 4730 4731 | # args A list of name-value pairs. # # Results: # TODO proc http::formatQuery {args} { if {[llength $args] % 2} { | | | | | | 4724 4725 4726 4727 4728 4729 4730 4731 4732 4733 4734 4735 4736 4737 4738 4739 4740 4741 | # args A list of name-value pairs. # # Results: # TODO proc http::formatQuery {args} { if {[llength $args] % 2} { return \ -code error \ -errorcode [list HTTP BADARGCNT $args] \ {Incorrect number of arguments, must be an even number.} } set result "" set sep "" foreach i $args { append result $sep [quoteString $i] if {$sep eq "="} { set sep & |
︙ | ︙ | |||
4781 4782 4783 4784 4785 4786 4787 | # # Results: # The current proxy settings proc http::ProxyRequired {host} { variable http if {(![info exists http(-proxyhost)]) || ($http(-proxyhost) eq {})} { | | | | | | 4780 4781 4782 4783 4784 4785 4786 4787 4788 4789 4790 4791 4792 4793 4794 4795 4796 4797 4798 4799 4800 4801 4802 4803 4804 4805 4806 4807 | # # Results: # The current proxy settings proc http::ProxyRequired {host} { variable http if {(![info exists http(-proxyhost)]) || ($http(-proxyhost) eq {})} { return } if {![info exists http(-proxyport)] || ($http(-proxyport) eq {})} { set port 8080 } else { set port $http(-proxyport) } # Simple test (cf. autoproxy) for hosts that must be accessed directly, # not through the proxy server. foreach domain $http(-proxynot) { if {[string match -nocase $domain $host]} { return {} } } return [list $http(-proxyhost) $port] } # http::CharsetToEncoding -- # # Tries to map a given IANA charset to a tcl encoding. If no encoding |
︙ | ︙ | |||
5007 5008 5009 5010 5011 5012 5013 | # ------------------------------------------------------------------------------ proc http::socketAsCallback {args} { variable http set targ [lsearch -exact $args -type] if {$targ != -1} { | | | | | | | | | | | | | | 5006 5007 5008 5009 5010 5011 5012 5013 5014 5015 5016 5017 5018 5019 5020 5021 5022 5023 5024 5025 5026 5027 5028 5029 5030 5031 5032 5033 5034 5035 5036 5037 5038 5039 5040 5041 5042 | # ------------------------------------------------------------------------------ proc http::socketAsCallback {args} { variable http set targ [lsearch -exact $args -type] if {$targ != -1} { set token [lindex $args $targ+1] upvar 0 ${token} state set protoProxyConn $state(protoProxyConn) } else { set protoProxyConn 0 } set host [lindex $args end-1] set port [lindex $args end] if { ($http(-proxyfilter) ne {}) && (![catch {$http(-proxyfilter) $host} proxy]) && $protoProxyConn } { set phost [lindex $proxy 0] set pport [lindex $proxy 1] } else { set phost {} set pport {} } if {$phost eq ""} { set sock [::http::AltSocket {*}$args] } else { set sock [::http::SecureProxyConnect {*}$args $phost $pport] } return $sock } # ------------------------------------------------------------------------------ # Proc http::SecureProxyConnect |
︙ | ︙ | |||
5075 5076 5077 5078 5079 5080 5081 | set args [lreplace $args end-3 end-2] # Proxy server URL for connection. # This determines where the socket is opened. set phost [lindex $args end-1] set pport [lindex $args end] if {[string first : $phost] != -1} { | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 5074 5075 5076 5077 5078 5079 5080 5081 5082 5083 5084 5085 5086 5087 5088 5089 5090 5091 5092 5093 5094 5095 5096 5097 5098 5099 5100 5101 5102 5103 5104 5105 5106 5107 5108 5109 5110 5111 5112 5113 5114 5115 5116 5117 5118 5119 5120 5121 5122 5123 5124 5125 5126 5127 5128 5129 5130 5131 5132 5133 5134 5135 5136 5137 5138 5139 5140 5141 5142 5143 5144 5145 5146 5147 5148 5149 5150 5151 5152 5153 5154 5155 5156 5157 5158 5159 5160 5161 5162 5163 5164 5165 5166 5167 5168 5169 5170 5171 5172 5173 5174 5175 5176 5177 5178 5179 5180 5181 5182 5183 5184 5185 5186 5187 5188 5189 5190 5191 5192 5193 5194 | set args [lreplace $args end-3 end-2] # Proxy server URL for connection. # This determines where the socket is opened. set phost [lindex $args end-1] set pport [lindex $args end] if {[string first : $phost] != -1} { # IPv6 address, wrap it in [] so we can append :pport set phost "\[${phost}\]" } set url http://${phost}:${pport} # Elements of args other than host and port are not used when # AsyncTransaction opens a socket. Those elements are -async and the # -type $tokenName for the https transaction. Option -async is used by # AsyncTransaction anyway, and -type $tokenName should not be # propagated: the proxy request adds its own -type value. set targ [lsearch -exact $args -type] if {$targ != -1} { # Record in the token that this is a proxy call. set token [lindex $args $targ+1] upvar 0 ${token} state set tim $state(-timeout) set state(proxyUsed) SecureProxyFailed # This value is overwritten with "SecureProxy" below if the CONNECT is # successful. If it is unsuccessful, the socket will be closed # below, and so in this unsuccessful case there are no other transactions # whose (proxyUsed) must be updated. } else { set tim 0 } if {$tim == 0} { # Do not use infinite timeout for the proxy. set tim 30000 } # Prepare and send a CONNECT request to the proxy, using # code similar to http::geturl. set requestHeaders [list Host $host] lappend requestHeaders Connection keep-alive if {$http(-proxyauth) != {}} { lappend requestHeaders Proxy-Authorization $http(-proxyauth) } set token2 [CreateToken $url -keepalive 0 -timeout $tim \ -headers $requestHeaders -command [list http::AllDone $varName]] variable $token2 upvar 0 $token2 state2 # Kludges: # Setting this variable overrides the HTTP request line and also allows # -headers to override the Connection: header set by -keepalive. # The arguments "-keepalive 0" ensure that when Finish is called for an # unsuccessful request, the socket is always closed. set state2(bypass) "CONNECT $host:$port HTTP/1.1" AsyncTransaction $token2 if {[info coroutine] ne {}} { # All callers in the http package are coroutines launched by # the event loop. # The cwait command requires a coroutine because it yields # to the caller; $varName is traced and the coroutine resumes # when the variable is written. cwait $varName } else { return -code error {code must run in a coroutine} # For testing with a non-coroutine caller outside the http package. # vwait $varName } unset $varName if { ($state2(state) ne "complete") || ($state2(status) ne "ok") || (![string is integer -strict $state2(responseCode)]) } { set msg {the HTTP request to the proxy server did not return a valid\ and complete response} if {[info exists state2(error)]} { append msg ": " [lindex $state2(error) 0] } cleanup $token2 return -code error $msg } set code $state2(responseCode) if {($code >= 200) && ($code < 300)} { # All OK. The caller in package tls will now call "tls::import $sock". # The cleanup command does not close $sock. # Other tidying was done in http::Event. # If this is a persistent socket, any other transactions that are # already marked to use the socket will have their (proxyUsed) updated # when http::OpenSocket calls http::ConfigureNewSocket. set state(proxyUsed) SecureProxy set sock $state2(sock) cleanup $token2 return $sock } if {$targ != -1} { # Non-OK HTTP status code; token is known because option -type # (cf. targ) was passed through tcltls, and so the useful # parts of the proxy's response can be copied to state(*). # Do not copy state2(sock). # Return the proxy response to the caller of geturl. foreach name $failedProxyValues { if {[info exists state2($name)]} { set state($name) $state2($name) } } set state(connection) close set msg "proxy connect failed: $code" # - This error message will be detected by http::OpenSocket and will # cause it to present the proxy's HTTP response as that of the # original $token transaction, identified only by state(proxyUsed) # as the response of the proxy. # - The cases where this would mislead the caller of http::geturl are # given a different value of msg (below) so that http::OpenSocket will # treat them as errors, but will preserve the $token array for |
︙ | ︙ | |||
5268 5269 5270 5271 5272 5273 5274 | variable ThreadCounter variable http LoadThreadIfNeeded set targ [lsearch -exact $args -type] if {$targ != -1} { | | | | | | | | | | | | | | | | | | | | | | | | | | 5267 5268 5269 5270 5271 5272 5273 5274 5275 5276 5277 5278 5279 5280 5281 5282 5283 5284 5285 5286 5287 5288 5289 5290 5291 5292 5293 5294 5295 5296 5297 5298 5299 5300 5301 5302 5303 5304 5305 5306 5307 5308 5309 5310 5311 5312 5313 5314 5315 5316 5317 5318 5319 5320 5321 5322 5323 5324 5325 5326 5327 5328 5329 5330 5331 5332 5333 5334 5335 5336 5337 | variable ThreadCounter variable http LoadThreadIfNeeded set targ [lsearch -exact $args -type] if {$targ != -1} { set token [lindex $args $targ+1] set args [lreplace $args $targ $targ+1] upvar 0 $token state } if {$http(usingThread) && [info exists state] && $state(protoSockThread)} { } else { # Use plain "::socket". This is the default. return [eval ::socket $args] } set defcmd ::socket set sockargs $args set script " set code \[catch { [list proc ::SockInThread {caller defcmd sockargs} [info body ::http::SockInThread]] [list ::SockInThread [thread::id] $defcmd $sockargs] } result opts\] list \$code \$opts \$result " set state(tid) [thread::create] set varName ::http::ThreadVar([incr ThreadCounter]) thread::send -async $state(tid) $script $varName Log >T Thread Start Wait $args -- coro [info coroutine] $varName if {[info coroutine] ne {}} { # All callers in the http package are coroutines launched by # the event loop. # The cwait command requires a coroutine because it yields # to the caller; $varName is traced and the coroutine resumes # when the variable is written. cwait $varName } else { return -code error {code must run in a coroutine} # For testing with a non-coroutine caller outside the http package. # vwait $varName } Log >U Thread End Wait $args -- coro [info coroutine] $varName [set $varName] thread::release $state(tid) set state(tid) {} set result [set $varName] unset $varName if {(![string is list $result]) || ([llength $result] != 3)} { return -code error "result from peer thread is not a list of\ length 3: it is \n$result" } lassign $result threadCode threadDict threadResult if {($threadCode != 0)} { # This is an error in thread::send. Return the lot. return -options $threadDict -code error $threadResult } # Now the results of the catch in the peer thread. lassign $threadResult catchCode errdict sock if {($catchCode == 0) && ($sock ni [chan names])} { return -code error {Transfer of socket from peer thread failed.\ Check that this script is not running in a child interpreter.} } return -options $errdict -code $catchCode $sock } # The commands below are dependencies of http::AltSocket and # http::SecureProxyConnect and are not used elsewhere. |
︙ | ︙ | |||
5352 5353 5354 5355 5356 5357 5358 | # Arguments: none # Return Value: none # ------------------------------------------------------------------------------ proc http::LoadThreadIfNeeded {} { variable http if {$http(-threadlevel) == 0} { | | | | | | | | | | | 5351 5352 5353 5354 5355 5356 5357 5358 5359 5360 5361 5362 5363 5364 5365 5366 5367 5368 5369 5370 5371 5372 5373 5374 5375 | # Arguments: none # Return Value: none # ------------------------------------------------------------------------------ proc http::LoadThreadIfNeeded {} { variable http if {$http(-threadlevel) == 0} { set http(usingThread) 0 return } if {[catch {package require Thread}]} { if {$http(-threadlevel) == 2} { set msg {[http::config -threadlevel] has value 2,\ but the Thread package is not available} return -code error $msg } set http(usingThread) 0 return } set http(usingThread) 1 return } # ------------------------------------------------------------------------------ |
︙ | ︙ | |||
5389 5390 5391 5392 5393 5394 5395 | # ------------------------------------------------------------------------------ proc http::SockInThread {caller defcmd sockargs} { package require Thread set catchCode [catch {eval $defcmd $sockargs} sock errdict] if {$catchCode == 0} { | | | 5388 5389 5390 5391 5392 5393 5394 5395 5396 5397 5398 5399 5400 5401 5402 | # ------------------------------------------------------------------------------ proc http::SockInThread {caller defcmd sockargs} { package require Thread set catchCode [catch {eval $defcmd $sockargs} sock errdict] if {$catchCode == 0} { set catchCode [catch {thread::transfer $caller $sock; set sock} sock errdict] } return [list $catchCode $errdict $sock] } # ------------------------------------------------------------------------------ # Proc http::cwaiter::cwait |
︙ | ︙ | |||
5426 5427 5428 5429 5430 5431 5432 | } proc http::cwaiter::cwait { varName {coroName {}} {timeout {}} {timeoutValue {}} } { set thisCoro [info coroutine] if {$thisCoro eq {}} { | | | | | | | | 5425 5426 5427 5428 5429 5430 5431 5432 5433 5434 5435 5436 5437 5438 5439 5440 5441 5442 5443 5444 5445 5446 5447 5448 5449 5450 5451 5452 | } proc http::cwaiter::cwait { varName {coroName {}} {timeout {}} {timeoutValue {}} } { set thisCoro [info coroutine] if {$thisCoro eq {}} { return -code error {cwait cannot be called outside a coroutine} } if {$coroName eq {}} { set coroName $thisCoro } if {[string range $varName 0 1] ne {::}} { return -code error {argument varName must be fully qualified} } if {$timeout eq {}} { set toe {} } elseif {[string is integer -strict $timeout] && ($timeout > 0)} { set toe [after $timeout [list set $varName $timeoutValue]] } else { return -code error {if timeout is supplied it must be a positive integer} } set cmd [list ::http::cwaiter::CwaitHelper $varName $coroName $toe] trace add variable $varName write $cmd CoLog "Yield $varName $coroName" yield CoLog "Resume $varName $coroName" |
︙ | ︙ | |||
5497 5498 5499 5500 5501 5502 5503 | return $log } proc http::cwaiter::CoLog {msg} { variable log variable logOn if {$logOn} { | | | 5496 5497 5498 5499 5500 5501 5502 5503 5504 5505 5506 5507 5508 5509 5510 5511 5512 5513 5514 | return $log } proc http::cwaiter::CoLog {msg} { variable log variable logOn if {$logOn} { append log $msg \n } return } namespace eval http { namespace import ::http::cwaiter::* } # Local variables: # indent-tabs-mode: t # End: |
Changes to library/init.tcl.
︙ | ︙ | |||
550 551 552 553 554 555 556 | set ns [uplevel 1 [list ::namespace current]] set patternList [auto_qualify $pattern $ns] auto_load_index foreach pattern $patternList { | | | | | | | 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 | set ns [uplevel 1 [list ::namespace current]] set patternList [auto_qualify $pattern $ns] auto_load_index foreach pattern $patternList { foreach name [array names auto_index $pattern] { if {([namespace which -command $name] eq "") && ([namespace qualifiers $pattern] eq [namespace qualifiers $name])} { namespace inscope :: $auto_index($name) } } } } # auto_execok -- # # Returns string that indicates name of program to execute if # name corresponds to a shell builtin or an executable in the |
︙ | ︙ |
Changes to library/msgcat/msgcat.tcl.
︙ | ︙ | |||
16 17 18 19 20 21 22 | # When the version number changes, be sure to update the pkgIndex.tcl file, # and the installation directory in the Makefiles. package provide msgcat 1.7.1 namespace eval msgcat { namespace export mc mcn mcexists mcload mclocale mcmax\ mcmset mcpreferences mcset\ | | | 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 | # When the version number changes, be sure to update the pkgIndex.tcl file, # and the installation directory in the Makefiles. package provide msgcat 1.7.1 namespace eval msgcat { namespace export mc mcn mcexists mcload mclocale mcmax\ mcmset mcpreferences mcset\ mcunknown mcflset mcflmset mcloadedlocales mcforgetpackage\ mcpackagenamespaceget mcpackageconfig mcpackagelocale mcutil # Records the list of locales to search variable Loclist {} # List of currently loaded locales variable LoadedLocales {} |
︙ | ︙ | |||
734 735 736 737 738 739 740 | if {[llength [info level 0]] == 4 } { # value provided if {$subcommand in {"get" "isset" "unset"}} { return -code error "wrong # args: should be\ \"[lrange [info level 0] 0 2] value\"" } } elseif {$subcommand eq "set"} { | | | 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 | if {[llength [info level 0]] == 4 } { # value provided if {$subcommand in {"get" "isset" "unset"}} { return -code error "wrong # args: should be\ \"[lrange [info level 0] 0 2] value\"" } } elseif {$subcommand eq "set"} { return -code error\ "wrong # args: should be \"[lrange [info level 0] 0 2]\"" } # Execute subcommands switch -exact -- $subcommand { get { # Operation get return current value if {![dict exists $PackageConfig $option $ns]} { |
︙ | ︙ |
Changes to library/opt/optparse.tcl.
︙ | ︙ | |||
13 14 15 16 17 18 19 | # and the install directory in the Makefiles. package provide opt 0.4.9 namespace eval ::tcl { # Exported APIs namespace export OptKeyRegister OptKeyDelete OptKeyError OptKeyParse \ | | | | | | | | | | | | | | | | | | | | | | | | | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 | # and the install directory in the Makefiles. package provide opt 0.4.9 namespace eval ::tcl { # Exported APIs namespace export OptKeyRegister OptKeyDelete OptKeyError OptKeyParse \ OptProc OptProcArgGiven OptParse \ Lempty Lget \ Lassign Lvarpop Lvarpop1 Lvarset Lvarincr \ SetMax SetMin ################# Example of use / 'user documentation' ################### proc OptCreateTestProc {} { # Defines ::tcl::OptParseTest as a test proc with parsed arguments # (can't be defined before the code below is loaded (before "OptProc")) # Every OptProc give usage information on "procname -help". # Try "tcl::OptParseTest -help" and "tcl::OptParseTest -a" and # then other arguments. # # example of 'valid' call: # ::tcl::OptParseTest save -4 -pr 23 -libsok SybTcl\ # -nostatics false ch1 OptProc OptParseTest { {subcommand -choice {save print} "sub command"} {arg1 3 "some number"} {-aflag} {-intflag 7} {-weirdflag "help string"} {-noStatics "Not ok to load static packages"} {-nestedloading1 true "OK to load into nested children"} {-nestedloading2 -boolean true "OK to load into nested children"} {-libsOK -choice {Tk SybTcl} "List of packages that can be loaded"} {-precision -int 12 "Number of digits of precision"} {-intval 7 "An integer"} {-scale -float 1.0 "Scale factor"} {-zoom 1.0 "Zoom factor"} {-arbitrary foobar "Arbitrary string"} {-random -string 12 "Random string"} {-listval -list {} "List value"} {-blahflag -blah abc "Funny type"} {arg2 -boolean "a boolean"} {arg3 -choice "ch1 ch2"} {?optarg? -list {} "optional argument"} } { foreach v [info locals] { puts stderr [format "%14s : %s" $v [set $v]] } } } ################### No User serviceable part below ! ############### |
︙ | ︙ | |||
142 143 144 145 146 147 148 | # Parse a given description and saves it here under the given key # generate a unused keyid if not given # proc ::tcl::OptKeyRegister {desc {key ""}} { variable OptDesc variable OptDescN if {[string equal $key ""]} { | | | | | | | | | | | | | | | | | | | | | | | | | | | | 142 143 144 145 146 147 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 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 | # Parse a given description and saves it here under the given key # generate a unused keyid if not given # proc ::tcl::OptKeyRegister {desc {key ""}} { variable OptDesc variable OptDescN if {[string equal $key ""]} { # in case a key given to us as a parameter was a number while {[info exists OptDesc($OptDescN)]} {incr OptDescN} set key $OptDescN incr OptDescN } # program counter set program [list [list "P" 1]] # are we processing flags (which makes a single program step) set inflags 0 set state {} # flag used to detect that we just have a single (flags set) subprogram. set empty 1 foreach item $desc { if {$state == "args"} { # more items after 'args'... return -code error "'args' special argument must be the last one" } set res [OptNormalizeOne $item] set state [lindex $res 0] if {$inflags} { if {$state == "flags"} { # add to 'subprogram' lappend flagsprg $res } else { # put in the flags # structure for flag programs items is a list of # {subprgcounter {prg flag 1} {prg flag 2} {...}} lappend program $flagsprg # put the other regular stuff lappend program $res set inflags 0 set empty 0 } } else { if {$state == "flags"} { set inflags 1 # sub program counter + first sub program set flagsprg [list [list "P" 1] $res] } else { lappend program $res set empty 0 } } } if {$inflags} { if {$empty} { # We just have the subprogram, optimize and remove # unneeded level: set program $flagsprg |
︙ | ︙ | |||
215 216 217 218 219 220 221 | proc ::tcl::OptKeyDelete {key} { variable OptDesc unset OptDesc($key) } # Get the parsed description stored under the given key. proc OptKeyGetDesc {descKey} { | | | | | | | 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 | proc ::tcl::OptKeyDelete {key} { variable OptDesc unset OptDesc($key) } # Get the parsed description stored under the given key. proc OptKeyGetDesc {descKey} { variable OptDesc if {![info exists OptDesc($descKey)]} { return -code error "Unknown option description key \"$descKey\"" } set OptDesc($descKey) } # Parse entry point for people who don't want to register with a key, # for instance because the description changes dynamically. # (otherwise one should really use OptKeyRegister once + OptKeyParse # as it is way faster or simply OptProc which does it all) # Assign a temporary key, call OptKeyParse and then free the storage |
︙ | ︙ | |||
244 245 246 247 248 249 250 | # and add a first line to the code to call the OptKeyParse proc # Stores the list of variables that have been actually given by the user # (the other will be sets to their default value) # into local variable named "Args". proc ::tcl::OptProc {name desc body} { set namespace [uplevel 1 [list ::namespace current]] if {[string match "::*" $name] || [string equal $namespace "::"]} { | | | | | | 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 | # and add a first line to the code to call the OptKeyParse proc # Stores the list of variables that have been actually given by the user # (the other will be sets to their default value) # into local variable named "Args". proc ::tcl::OptProc {name desc body} { set namespace [uplevel 1 [list ::namespace current]] if {[string match "::*" $name] || [string equal $namespace "::"]} { # absolute name or global namespace, name is the key set key $name } else { # we are relative to some non top level namespace: set key "${namespace}::${name}" } OptKeyRegister $desc $key uplevel 1 [list ::proc $name args "set Args \[::tcl::OptKeyParse $key \$args\]\n$body"] return $key } # Check that a argument has been given # assumes that "OptProc" has been used as it will check in "Args" list |
︙ | ︙ | |||
296 297 298 299 300 301 302 | lappend res [Lget $lst $idx] } return $res } # Advance to next description proc OptNextDesc {descName} { | | | | | | | | | | | | | | | | | | | 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 321 322 323 324 325 326 327 328 329 330 331 332 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 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 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 409 410 411 412 413 414 415 416 417 418 419 420 421 | lappend res [Lget $lst $idx] } return $res } # Advance to next description proc OptNextDesc {descName} { uplevel 1 [list Lvarincr $descName {0 1}] } # Get the current description, eventually descend proc OptCurDesc {descriptions} { lindex $descriptions [OptGetPrgCounter $descriptions] } # get the current description, eventually descend # through sub programs as needed. proc OptCurDescFinal {descriptions} { set item [OptCurDesc $descriptions] # Descend untill we get the actual item and not a sub program while {[OptIsPrg $item]} { set item [OptCurDesc $item] } return $item } # Current final instruction adress proc OptCurAddr {descriptions {start {}}} { set adress [OptGetPrgCounter $descriptions] lappend start $adress set item [lindex $descriptions $adress] if {[OptIsPrg $item]} { return [OptCurAddr $item $start] } else { return $start } } # Set the value field of the current instruction. proc OptCurSetValue {descriptionsName value} { upvar $descriptionsName descriptions # Get the current item full address. set adress [OptCurAddr $descriptions] # Use the 3rd field of the item (see OptValue / OptNewInst). lappend adress 2 Lvarset descriptions $adress [list 1 $value] # ^hasBeenSet flag } # Empty state means done/paste the end of the program. proc OptState {item} { lindex $item 0 } # current state proc OptCurState {descriptions} { OptState [OptCurDesc $descriptions] } ####### # Arguments manipulation # Returns the argument that has to be processed now. proc OptCurrentArg {lst} { lindex $lst 0 } # Advance to next argument. proc OptNextArg {argsName} { uplevel 1 [list Lvarpop1 $argsName] } ####### # Loop over all descriptions, calling OptDoOne which will # eventually eat all the arguments. proc OptDoAll {descriptionsName argumentsName} { upvar $descriptionsName descriptions upvar $argumentsName arguments # puts "entered DoAll" # Nb: the places where "state" can be set are tricky to figure # because DoOne sets the state to flagsValue and return -continue # when needed... set state [OptCurState $descriptions] # We'll exit the loop in "OptDoOne" or when state is empty. while 1 { set curitem [OptCurDesc $descriptions] # Do subprograms if needed, call ourselves on the sub branch while {[OptIsPrg $curitem]} { OptDoAll curitem arguments # puts "done DoAll sub" # Insert back the results in current tree Lvarset1nc descriptions [OptGetPrgCounter $descriptions]\ $curitem OptNextDesc descriptions set curitem [OptCurDesc $descriptions] set state [OptCurState $descriptions] } # puts "state = \"$state\" - arguments=($arguments)" if {[Lempty $state]} { # Nothing left to do, we are done in this branch: break } # The following statement can make us terminate/continue # as it use return -code {break, continue, return and error} # codes OptDoOne descriptions state arguments # If we are here, no special return code where issued, # we'll step to next instruction : # puts "new state = \"$state\"" OptNextDesc descriptions set state [OptCurState $descriptions] } } # Process one step for the state machine, # eventually consuming the current argument. proc OptDoOne {descriptionsName stateName argumentsName} { upvar $argumentsName arguments upvar $descriptionsName descriptions upvar $stateName state # the special state/instruction "args" eats all # the remaining args (if any) if {($state == "args")} { if {![Lempty $arguments]} { # If there is no additional arguments, leave the default value |
︙ | ︙ | |||
439 440 441 442 443 444 445 | } else { return -code error [OptMissingValue $descriptions] } } else { set arg [OptCurrentArg $arguments] } | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 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 | } else { return -code error [OptMissingValue $descriptions] } } else { set arg [OptCurrentArg $arguments] } switch $state { flags { # A non-dash argument terminates the options, as does -- # Still a flag ? if {![OptIsFlag $arg]} { # don't consume the argument, return to previous prg return -code return } # consume the flag OptNextArg arguments if {[string equal "--" $arg]} { # return from 'flags' state return -code return } set hits [OptHits descriptions $arg] if {$hits > 1} { return -code error [OptAmbigous $descriptions $arg] } elseif {$hits == 0} { return -code error [OptFlagUsage $descriptions $arg] } set item [OptCurDesc $descriptions] if {[OptNeedValue $item]} { # we need a value, next state is set state flagValue } else { OptCurSetValue descriptions 1 } # continue return -code continue } flagValue - value { set item [OptCurDesc $descriptions] # Test the values against their required type if {[catch {OptCheckType $arg\ [OptType $item] [OptTypeArgs $item]} val]} { return -code error [OptBadValue $item $arg $val] } # consume the value OptNextArg arguments # set the value OptCurSetValue descriptions $val # go to next state if {$state == "flagValue"} { set state flags return -code continue } else { set state next; # not used, for debug only return ; # will go on next step } } optValue { set item [OptCurDesc $descriptions] # Test the values against their required type if {![catch {OptCheckType $arg\ [OptType $item] [OptTypeArgs $item]} val]} { # right type, so : # consume the value OptNextArg arguments # set the value OptCurSetValue descriptions $val } # go to next state set state next; # not used, for debug only return ; # will go on next step } } # If we reach this point: an unknown # state as been entered ! return -code error "Bug! unknown state in DoOne \"$state\"\ (prg counter [OptGetPrgCounter $descriptions]:\ [OptCurDesc $descriptions])" } |
︙ | ︙ | |||
572 573 574 575 576 577 578 | # otherwise returns the canonical value of that arg (ie 0/1 for booleans) proc ::tcl::OptCheckType {arg type {typeArgs ""}} { # puts "checking '$arg' against '$type' ($typeArgs)" # only types "any", "choice", and numbers can have leading "-" switch -exact -- $type { | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 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 640 641 642 643 644 645 646 647 648 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 678 679 680 681 682 683 684 685 686 687 688 689 690 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 736 737 738 739 740 741 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 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 | # otherwise returns the canonical value of that arg (ie 0/1 for booleans) proc ::tcl::OptCheckType {arg type {typeArgs ""}} { # puts "checking '$arg' against '$type' ($typeArgs)" # only types "any", "choice", and numbers can have leading "-" switch -exact -- $type { int { if {![string is integer -strict $arg]} { error "not an integer" } return $arg } float { return [expr {double($arg)}] } script - list { # if llength fail : malformed list if {[llength $arg]==0 && [OptIsFlag $arg]} { error "no values with leading -" } return $arg } boolean { if {![string is boolean -strict $arg]} { error "non canonic boolean" } # convert true/false because expr/if is broken with "!,... return [expr {$arg ? 1 : 0}] } choice { if {$arg ni $typeArgs} { error "invalid choice" } return $arg } any { return $arg } string - default { if {[OptIsFlag $arg]} { error "no values with leading -" } return $arg } } return neverReached } # internal utilities # returns the number of flags matching the given arg # sets the (local) prg counter to the list of matches proc OptHits {descName arg} { upvar $descName desc set hits 0 set hitems {} set i 1 set larg [string tolower $arg] set len [string length $larg] set last [expr {$len-1}] foreach item [lrange $desc 1 end] { set flag [OptName $item] # lets try to match case insensitively # (string length ought to be cheap) set lflag [string tolower $flag] if {$len == [string length $lflag]} { if {[string equal $larg $lflag]} { # Exact match case OptSetPrgCounter desc $i return 1 } } elseif {[string equal $larg [string range $lflag 0 $last]]} { lappend hitems $i incr hits } incr i } if {$hits} { OptSetPrgCounter desc $hitems } return $hits } # Extract fields from the list structure: proc OptName {item} { lindex $item 1 } proc OptHasBeenSet {item} { Lget $item {2 0} } proc OptValue {item} { Lget $item {2 1} } proc OptIsFlag {name} { string match "-*" $name } proc OptIsOpt {name} { string match {\?*} $name } proc OptVarName {item} { set name [OptName $item] if {[OptIsFlag $name]} { return [string range $name 1 end] } elseif {[OptIsOpt $name]} { return [string trim $name "?"] } else { return $name } } proc OptType {item} { lindex $item 3 } proc OptTypeArgs {item} { lindex $item 4 } proc OptHelp {item} { lindex $item 5 } proc OptNeedValue {item} { expr {![string equal [OptType $item] boolflag]} } proc OptDefaultValue {item} { set val [OptTypeArgs $item] switch -exact -- [OptType $item] { choice {return [lindex $val 0]} boolean - boolflag { # convert back false/true to 0/1 because expr !$bool # is broken.. if {$val} { return 1 } else { return 0 } } } return $val } # Description format error helper proc OptOptUsage {item {what ""}} { return -code error "invalid description format$what: $item\n\ should be a list of {varname|-flagname ?-type? ?defaultvalue?\ ?helpstring?}" } # Generate a canonical form single instruction proc OptNewInst {state varname type typeArgs help} { list $state $varname [list 0 {}] $type $typeArgs $help # ^ ^ # | | # hasBeenSet=+ +=currentValue } # Translate one item to canonical form proc OptNormalizeOne {item} { set lg [Lassign $item varname arg1 arg2 arg3] # puts "called optnormalizeone '$item' v=($varname), lg=$lg" set isflag [OptIsFlag $varname] set isopt [OptIsOpt $varname] if {$isflag} { set state "flags" } elseif {$isopt} { set state "optValue" } elseif {![string equal $varname "args"]} { set state "value" } else { set state "args" } # apply 'smart' 'fuzzy' logic to try to make # description writer's life easy, and our's difficult : # let's guess the missing arguments :-) switch $lg { 1 { if {$isflag} { return [OptNewInst $state $varname boolflag false ""] } else { return [OptNewInst $state $varname any "" ""] } } 2 { # varname default # varname help set type [OptGuessType $arg1] if {[string equal $type "string"]} { if {$isflag} { set type boolflag set def false } else { set type any set def "" } set help $arg1 } else { set help "" set def $arg1 } return [OptNewInst $state $varname $type $def $help] } 3 { # varname type value # varname value comment if {[regexp {^-(.+)$} $arg1 x type]} { # flags/optValue as they are optional, need a "value", # on the contrary, for a variable (non optional), # default value is pointless, 'cept for choices : if {$isflag || $isopt || ($type == "choice")} { return [OptNewInst $state $varname $type $arg2 ""] } else { return [OptNewInst $state $varname $type "" $arg2] } } else { return [OptNewInst $state $varname\ [OptGuessType $arg1] $arg1 $arg2] } } 4 { if {[regexp {^-(.+)$} $arg1 x type]} { return [OptNewInst $state $varname $type $arg2 $arg3] } else { return -code error [OptOptUsage $item] } } default { return -code error [OptOptUsage $item] } } } # Auto magic lazy type determination proc OptGuessType {arg} { if { $arg == "true" || $arg == "false" } { return boolean } if {[string is integer -strict $arg]} { return int } if {[string is double -strict $arg]} { return float } return string } # Error messages front ends proc OptAmbigous {desc arg} { OptError "ambigous option \"$arg\", choose from:" [OptSelection $desc] } proc OptFlagUsage {desc arg} { OptError "bad flag \"$arg\", must be one of" $desc } proc OptTooManyArgs {desc arguments} { OptError "too many arguments (unexpected argument(s): $arguments),\ usage:"\ $desc 1 } proc OptParamType {item} { if {[OptIsFlag $item]} { return "flag" } else { return "parameter" } } proc OptBadValue {item arg {err {}}} { # puts "bad val err = \"$err\"" OptError "bad value \"$arg\" for [OptParamType $item]"\ [list $item] } proc OptMissingValue {descriptions} { # set item [OptCurDescFinal $descriptions] set item [OptCurDesc $descriptions] OptError "no value given for [OptParamType $item] \"[OptName $item]\"\ (use -help for full usage) :"\ [list $item] } proc ::tcl::OptKeyError {prefix descKey {header 0}} { OptError $prefix [OptKeyGetDesc $descKey] $header } |
︙ | ︙ | |||
939 940 941 942 943 944 945 | proc ::tcl::Lempty {list} { expr {[llength $list]==0} } # Gets the value of one leaf of a lists tree proc ::tcl::Lget {list indexLst} { if {[llength $indexLst] <= 1} { | | | | | | | | | | | | | | | | | | | | | | | | | | 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 | proc ::tcl::Lempty {list} { expr {[llength $list]==0} } # Gets the value of one leaf of a lists tree proc ::tcl::Lget {list indexLst} { if {[llength $indexLst] <= 1} { return [lindex $list $indexLst] } Lget [lindex $list [lindex $indexLst 0]] [lrange $indexLst 1 end] } # Sets the value of one leaf of a lists tree # (we use the version that does not create the elements because # it would be even slower... needs to be written in C !) # (nb: there is a non trivial recursive problem with indexes 0, # which appear because there is no difference between a list # of 1 element and 1 element alone : [list "a"] == "a" while # it should be {a} and [listp a] should be 0 while [listp {a b}] would be 1 # and [listp "a b"] maybe 0. listp does not exist either...) proc ::tcl::Lvarset {listName indexLst newValue} { upvar $listName list if {[llength $indexLst] <= 1} { Lvarset1nc list $indexLst $newValue } else { set idx [lindex $indexLst 0] set targetList [lindex $list $idx] # reduce refcount on targetList (not really usefull now, # could be with optimizing compiler) # Lvarset1 list $idx {} # recursively replace in targetList Lvarset targetList [lrange $indexLst 1 end] $newValue # put updated sub list back in the tree Lvarset1nc list $idx $targetList } } # Set one cell to a value, eventually create all the needed elements # (on level-1 of lists) variable emptyList {} proc ::tcl::Lvarset1 {listName index newValue} { upvar $listName list if {$index < 0} {return -code error "invalid negative index"} set lg [llength $list] if {$index >= $lg} { variable emptyList for {set i $lg} {$i<$index} {incr i} { lappend list $emptyList } lappend list $newValue } else { set list [lreplace $list $index $index $newValue] } } # same as Lvarset1 but no bound checking / creation proc ::tcl::Lvarset1nc {listName index newValue} { upvar $listName list set list [lreplace $list $index $index $newValue] } # Increments the value of one leaf of a lists tree # (which must exists) proc ::tcl::Lvarincr {listName indexLst {howMuch 1}} { upvar $listName list if {[llength $indexLst] <= 1} { Lvarincr1 list $indexLst $howMuch } else { set idx [lindex $indexLst 0] set targetList [lindex $list $idx] # reduce refcount on targetList Lvarset1nc list $idx {} # recursively replace in targetList Lvarincr targetList [lrange $indexLst 1 end] $howMuch # put updated sub list back in the tree Lvarset1nc list $idx $targetList } } # Increments the value of one cell of a list proc ::tcl::Lvarincr1 {listName index {howMuch 1}} { upvar $listName list set newValue [expr {[lindex $list $index]+$howMuch}] set list [lreplace $list $index $index $newValue] |
︙ | ︙ | |||
1033 1034 1035 1036 1037 1038 1039 | } # Assign list elements to variables and return the length of the list proc ::tcl::Lassign {list args} { # faster than direct blown foreach (which does not byte compile) set i 0 set lg [llength $list] foreach vname $args { | | | | | | | 1033 1034 1035 1036 1037 1038 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 1065 1066 1067 1068 1069 1070 1071 1072 | } # Assign list elements to variables and return the length of the list proc ::tcl::Lassign {list args} { # faster than direct blown foreach (which does not byte compile) set i 0 set lg [llength $list] foreach vname $args { if {$i>=$lg} break uplevel 1 [list ::set $vname [lindex $list $i]] incr i } return $lg } # Misc utilities # Set the varname to value if value is greater than varname's current value # or if varname is undefined proc ::tcl::SetMax {varname value} { upvar 1 $varname var if {![info exists var] || $value > $var} { set var $value } } # Set the varname to value if value is smaller than varname's current value # or if varname is undefined proc ::tcl::SetMin {varname value} { upvar 1 $varname var if {![info exists var] || $value < $var} { set var $value } } # everything loaded fine, lets create the test proc: # OptCreateTestProc # Don't need the create temp proc anymore: # rename OptCreateTestProc {} } |
Changes to library/package.tcl.
︙ | ︙ | |||
27 28 29 30 31 32 33 | # Results: # Returns 1 if the extension matches, 0 otherwise proc tcl::Pkg::CompareExtension {fileName {ext {}}} { global tcl_platform if {$ext eq ""} {set ext [info sharedlibextension]} if {$tcl_platform(platform) eq "windows"} { | | | | | | | | | | | | 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 | # Results: # Returns 1 if the extension matches, 0 otherwise proc tcl::Pkg::CompareExtension {fileName {ext {}}} { global tcl_platform if {$ext eq ""} {set ext [info sharedlibextension]} if {$tcl_platform(platform) eq "windows"} { return [string equal -nocase [file extension $fileName] $ext] } else { # Some unices add trailing numbers after the .so, so # we could have something like '.so.1.2'. set root $fileName while {1} { set currExt [file extension $root] if {$currExt eq $ext} { return 1 } # The current extension does not match; if it is not a numeric # value, quit, as we are only looking to ignore version number # extensions. Otherwise we might return 1 in this case: # tcl::Pkg::CompareExtension foo.so.bar .so # which should not match. if {![string is integer -strict [string range $currExt 1 end]]} { return 0 } set root [file rootname $root] } } } # pkg_mkIndex -- # This procedure creates a package index in a given directory. The package # index consists of a "pkgIndex.tcl" file whose contents are a Tcl script that |
︙ | ︙ |
Changes to library/platform/shell.tcl.
︙ | ︙ | |||
127 128 129 130 131 132 133 | set cc [open $c w] puts $cc $code close $cc set e [TEMP] set code [catch { | | | 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 | set cc [open $c w] puts $cc $code close $cc set e [TEMP] set code [catch { exec $shell $c 2> $e } res] file delete $c if {$code} { append res \n[read [set chan [open $e r]]][close $chan] file delete $e |
︙ | ︙ |
Changes to library/safe.tcl.
︙ | ︙ | |||
76 77 78 79 80 81 82 | # #### # Interface/entry point function and front end for "Create" proc ::safe::interpCreate {args} { variable AutoPathSync if {$AutoPathSync} { | | | | 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 | # #### # Interface/entry point function and front end for "Create" proc ::safe::interpCreate {args} { variable AutoPathSync if {$AutoPathSync} { set autoPath {} } set Args [::tcl::OptKeyParse ::safe::interpCreate $args] RejectExcessColons $child set withAutoPath [::tcl::OptProcArgGiven -autoPath] InterpCreate $child $accessPath \ [InterpStatics] [InterpNested] $deleteHook $autoPath $withAutoPath } proc ::safe::interpInit {args} { variable AutoPathSync if {$AutoPathSync} { set autoPath {} } set Args [::tcl::OptKeyParse ::safe::interpIC $args] if {![::interp exists $child]} { return -code error "\"$child\" is not an interpreter" } RejectExcessColons $child |
︙ | ︙ | |||
140 141 142 143 144 145 146 | CheckInterp $child namespace upvar ::safe [VarName $child] state set TMP [list \ [list -accessPath $state(access_path)] \ [list -statics $state(staticsok)] \ [list -nested $state(nestedok)] \ | | | | 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 | CheckInterp $child namespace upvar ::safe [VarName $child] state set TMP [list \ [list -accessPath $state(access_path)] \ [list -statics $state(staticsok)] \ [list -nested $state(nestedok)] \ [list -deleteHook $state(cleanupHook)] \ ] if {!$AutoPathSync} { lappend TMP [list -autoPath $state(auto_path)] } return [join $TMP] } 2 { # If we have exactly 2 arguments the semantic is a "configure # get" lassign $args child arg |
︙ | ︙ | |||
172 173 174 175 176 177 178 | set name [::tcl::OptName $item] switch -exact -- $name { -accessPath { return [list -accessPath $state(access_path)] } -autoPath { if {$AutoPathSync} { | | | | 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 | set name [::tcl::OptName $item] switch -exact -- $name { -accessPath { return [list -accessPath $state(access_path)] } -autoPath { if {$AutoPathSync} { return -code error "unknown flag $name (bug)" } else { return [list -autoPath $state(auto_path)] } } -statics { return [list -statics $state(staticsok)] } -nested { return [list -nested $state(nestedok)] |
︙ | ︙ | |||
376 377 378 379 380 381 382 | set raw_auto_path $access_path # Add 1st level subdirs (will searched by auto loading from tcl # code in the child using glob and thus fail, so we add them here # so by default it works the same). set access_path [AddSubDirs $access_path] } else { | | | | | 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 | set raw_auto_path $access_path # Add 1st level subdirs (will searched by auto loading from tcl # code in the child using glob and thus fail, so we add them here # so by default it works the same). set access_path [AddSubDirs $access_path] } else { set raw_auto_path $autoPath } if {$withAutoPath} { set raw_auto_path $autoPath } Log $child "Setting accessPath=($access_path) staticsok=$staticsok\ nestedok=$nestedok deletehook=($deletehook)" NOTICE if {!$AutoPathSync} { Log $child "Setting auto_path=($raw_auto_path)" NOTICE } namespace upvar ::safe [VarName $child] state # clear old autopath if it existed # build new one # Extend the access list with the paths used to look for Tcl Modules. |
︙ | ︙ | |||
437 438 439 440 441 442 443 | set addpaths $morepaths set morepaths {} foreach dir $addpaths { # Prevent the addition of dirs on the tm list to the # result if they are already known. if {[dict exists $remap_access_path $dir]} { | | | 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 | set addpaths $morepaths set morepaths {} foreach dir $addpaths { # Prevent the addition of dirs on the tm list to the # result if they are already known. if {[dict exists $remap_access_path $dir]} { if {$firstpass} { # $dir is in [::tcl::tm::list] and belongs in the child_tm_path. # Later passes handle subdirectories, which belong in the # access path but not in the module path. lappend child_tm_path [dict get $remap_access_path $dir] } continue } |
︙ | ︙ | |||
482 483 484 485 486 487 488 | set state(access_path,child) $child_access_path set state(tm_path_child) $child_tm_path set state(staticsok) $staticsok set state(nestedok) $nestedok set state(cleanupHook) $deletehook if {!$AutoPathSync} { | | | 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 | set state(access_path,child) $child_access_path set state(tm_path_child) $child_tm_path set state(staticsok) $staticsok set state(nestedok) $nestedok set state(cleanupHook) $deletehook if {!$AutoPathSync} { set state(auto_path) $raw_auto_path } SyncAccessPath $child return } |
︙ | ︙ | |||
683 684 685 686 687 688 689 | # When an interpreter is deleted with [interp delete], any sub-interpreters # are deleted automatically, but this leaves behind their data in the Safe # Base. To clean up properly, we call safe::interpDelete recursively on each # Safe Base sub-interpreter, so each one is deleted cleanly and not by # the automatic mechanism built into [interp delete]. foreach sub [interp children $child] { | | | | | 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 | # When an interpreter is deleted with [interp delete], any sub-interpreters # are deleted automatically, but this leaves behind their data in the Safe # Base. To clean up properly, we call safe::interpDelete recursively on each # Safe Base sub-interpreter, so each one is deleted cleanly and not by # the automatic mechanism built into [interp delete]. foreach sub [interp children $child] { if {[info exists ::safe::[VarName [list $child $sub]]]} { ::safe::interpDelete [list $child $sub] } } # If the child has a cleanup hook registered, call it. Check the # existence because we might be called to delete an interp which has # not been registered with us at all if {[info exists state(cleanupHook)]} { |
︙ | ︙ | |||
1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 | set f [open $realfile] fconfigure $f -encoding $encoding -eofchar \x1A set contents [read $f] close $f ::interp eval $child [list info script $file] } msg opt] if {$code == 0} { set code [catch {::interp eval $child $contents} msg opt] set replacementMsg $msg } catch {interp eval $child [list info script $old]} # Note that all non-errors are fine result codes from [source], so we must # take a little care to do it properly. [Bug 2923613] if {$code == 1} { | > > > > | 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 | set f [open $realfile] fconfigure $f -encoding $encoding -eofchar \x1A set contents [read $f] close $f ::interp eval $child [list info script $file] } msg opt] if {$code == 0} { # See [Bug 1d26e580cf] if {[string index $contents 0] eq "\uFEFF"} { set contents [string range $contents 1 end] } set code [catch {::interp eval $child $contents} msg opt] set replacementMsg $msg } catch {interp eval $child [list info script $old]} # Note that all non-errors are fine result codes from [source], so we must # take a little care to do it properly. [Bug 2923613] if {$code == 1} { |
︙ | ︙ | |||
1276 1277 1278 1279 1280 1281 1282 | # becomes # namespace upvar ::safe [VarName $child] state # ------------------------------------------------------------------------------ proc ::safe::RejectExcessColons {child} { set stripped [regsub -all -- {:::*} $child ::] if {[string range $stripped end-1 end] eq {::}} { | | | | | | 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 | # becomes # namespace upvar ::safe [VarName $child] state # ------------------------------------------------------------------------------ proc ::safe::RejectExcessColons {child} { set stripped [regsub -all -- {:::*} $child ::] if {[string range $stripped end-1 end] eq {::}} { return -code error {interpreter name must not end in "::"} } if {$stripped ne $child} { set msg {interpreter name has excess colons in namespace separators} return -code error $msg } if {[string range $stripped 0 1] eq {::}} { return -code error {interpreter name must not begin "::"} } return } proc ::safe::VarName {child} { # return S$child return S[string map {:: @N @ @A} $child] |
︙ | ︙ | |||
1311 1312 1313 1314 1315 1316 1317 | {-noStatics "prevent loading of statically linked pkgs"} {-statics true "loading of statically linked pkgs"} {-nestedLoadOk "allow nested loading"} {-nested false "nested loading"} {-deleteHook -script {} "delete hook"} } if {!$AutoPathSync} { | | | 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 | {-noStatics "prevent loading of statically linked pkgs"} {-statics true "loading of statically linked pkgs"} {-nestedLoadOk "allow nested loading"} {-nested false "nested loading"} {-deleteHook -script {} "delete hook"} } if {!$AutoPathSync} { lappend OptList {-autoPath -list {} "::auto_path for the child"} } set temp [::tcl::OptKeyRegister $OptList] # create case (child is optional) ::tcl::OptKeyRegister { {?child? -name {} "name of the child (optional)"} } ::safe::interpCreate |
︙ | ︙ | |||
1369 1370 1371 1372 1373 1374 1375 | # because Setup has not yet been called.) proc ::safe::setSyncMode {args} { variable AutoPathSync if {[llength $args] == 0} { } elseif {[llength $args] == 1} { | | | | | | | | | | | | | | | | | | | | | 1373 1374 1375 1376 1377 1378 1379 1380 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 | # because Setup has not yet been called.) proc ::safe::setSyncMode {args} { variable AutoPathSync if {[llength $args] == 0} { } elseif {[llength $args] == 1} { set newValue [lindex $args 0] if {![string is boolean -strict $newValue]} { return -code error "new value must be a valid boolean" } set args [expr {$newValue && $newValue}] if {([info vars ::safe::S*] ne {}) && ($args != $AutoPathSync)} { return -code error \ "cannot set new value while Safe Base child interpreters exist" } if {($args != $AutoPathSync)} { set AutoPathSync {*}$args ::tcl::OptKeyDelete ::safe::interpCreate ::tcl::OptKeyDelete ::safe::interpIC set TmpLog [setLogCmd] Setup setLogCmd $TmpLog } } else { set msg {wrong # args: should be "safe::setSyncMode ?newValue?"} return -code error $msg } return $AutoPathSync } namespace eval ::safe { # internal variables (must not begin with "S") |
︙ | ︙ |
Changes to library/tcltest/tcltest.tcl.
︙ | ︙ | |||
1154 1155 1156 1157 1158 1159 1160 | # # Side effects: # None. proc tcltest::Asciify {s} { set print "" foreach c [split $s ""] { | | | | | | | | | | | 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 | # # Side effects: # None. proc tcltest::Asciify {s} { set print "" foreach c [split $s ""] { if {(($c < "\x7F") && [string is print $c]) || ($c eq "\n")} { append print $c } elseif {$c < "\u0100"} { append print \\x[format %02X [scan $c %c]] } elseif {$c > "\uFFFF"} { append print \\U[format %08X [scan $c %c]] } else { append print \\u[format %04X [scan $c %c]] } } return $print } # tcltest::ConstraintInitializer -- # # Get or set a script that when evaluated in the tcltest namespace |
︙ | ︙ | |||
1343 1344 1345 1346 1347 1348 1349 | ConstraintInitializer eformat {string equal [format %g 5e-5] 5e-05} # Test to see if execed commands such as cat, echo, rm and so forth # are present on this machine. ConstraintInitializer unixExecs { set code 1 | | | | | | | | | | | | | | | | | | | | | | 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 | ConstraintInitializer eformat {string equal [format %g 5e-5] 5e-05} # Test to see if execed commands such as cat, echo, rm and so forth # are present on this machine. ConstraintInitializer unixExecs { set code 1 if {$::tcl_platform(platform) eq "macintosh"} { set code 0 } if {$::tcl_platform(platform) eq "windows"} { if {[catch { set file _tcl_test_remove_me.txt makeFile {hello} $file }]} { set code 0 } elseif { [catch {exec cat $file}] || [catch {exec echo hello}] || [catch {exec sh -c echo hello}] || [catch {exec wc $file}] || [catch {exec sleep 1}] || [catch {exec echo abc > $file}] || [catch {exec chmod 644 $file}] || [catch {exec rm $file}] || [llength [auto_execok mkdir]] == 0 || [llength [auto_execok fgrep]] == 0 || [llength [auto_execok grep]] == 0 || [llength [auto_execok ps]] == 0 } { set code 0 } removeFile $file } set code } ConstraintInitializer stdio { variable fullutf set code 0 |
︙ | ︙ | |||
1544 1545 1546 1547 1548 1549 1550 | "missing value for option [lindex $args 0]" exit 1 } } # Call the hook catch { | | | | 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 | "missing value for option [lindex $args 0]" exit 1 } } # Call the hook catch { array set flag $flagArray processCmdLineArgsHook [array get flag] } return } # tcltest::ProcessCmdLineArgs -- # # This procedure must be run after constraint initialization is |
︙ | ︙ | |||
1728 1729 1730 1731 1732 1733 1734 | # # Side effects: # None. proc tcltest::CompareStrings {actual expected mode} { variable CustomMatch if {![info exists CustomMatch($mode)]} { | | | 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 | # # Side effects: # None. proc tcltest::CompareStrings {actual expected mode} { variable CustomMatch if {![info exists CustomMatch($mode)]} { return -code error "No matching command registered for `-match $mode'" } set match [namespace eval :: $CustomMatch($mode) [list $expected $actual]] if {[catch {expr {$match && $match}} result]} { return -code error "Invalid result from `-match $mode' command: $result" } return $match } |
︙ | ︙ | |||
1806 1807 1808 1809 1810 1811 1812 | # separated strings as it throws away the whitespace which maybe # important so we have to do it all by hand. set result {} set token "" while {[string length $argList]} { | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 | # separated strings as it throws away the whitespace which maybe # important so we have to do it all by hand. set result {} set token "" while {[string length $argList]} { # Look for the next word containing a quote: " { } if {[regexp -indices {[^ \t\n]*[\"\{\}]+[^ \t\n]*} \ $argList all]} { # Get the text leading up to this word, but not including # this word, from the argList. set text [string range $argList 0 \ [expr {[lindex $all 0] - 1}]] # Get the word with the quote set word [string range $argList \ [lindex $all 0] [lindex $all 1]] # Remove all text up to and including the word from the # argList. set argList [string range $argList \ [expr {[lindex $all 1] + 1}] end] } else { # Take everything up to the end of the argList. set text $argList set word {} set argList {} } if {$token ne {}} { # If we saw a word with quote before, then there is a # multi-word token starting with that word. In this case, # add the text and the current word to this token. append token $text $word } else { # Add the text to the result. There is no need to parse # the text because it couldn't be a part of any multi-word # token. Then start a new multi-word token with the word # because we need to pass this token to the Tcl parser to # check for balancing quotes append result $text set token $word } if { [catch {llength $token} length] == 0 && $length == 1} { # The token is a valid list so add it to the result. # lappend result [string trim $token] append result \{$token\} set token {} } } # If the last token has not been added to the list then there # is a problem. if { [string length $token] } { error "incomplete token \"$token\"" } return $result } # tcltest::test -- |
︙ | ︙ | |||
2005 2006 2007 2008 2009 2010 2011 | must be $values" } # Replace symbolic valies supplied for -returnCodes foreach {strcode numcode} {ok 0 normal 0 error 1 return 2 break 3 continue 4} { set returnCodes [string map -nocase [list $strcode $numcode] $returnCodes] } | | | | | | 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 | must be $values" } # Replace symbolic valies supplied for -returnCodes foreach {strcode numcode} {ok 0 normal 0 error 1 return 2 break 3 continue 4} { set returnCodes [string map -nocase [list $strcode $numcode] $returnCodes] } # errorCode without returnCode 1 is meaningless if {$errorCode ne "*" && 1 ni $returnCodes} { set returnCodes 1 } } else { # This is parsing for the old test command format; it is here # for backward compatibility. set result [lindex $args end] if {[llength $args] == 2} { set body [lindex $args 0] } elseif {[llength $args] == 3} { |
︙ | ︙ | |||
2091 2092 2093 2094 2095 2096 2097 | # check if the return code matched the expected return code set codeFailure 0 if {$processTest && !$setupFailure && ($returnCode ni $returnCodes)} { set codeFailure 1 } set errorCodeFailure 0 if {$processTest && !$setupFailure && !$codeFailure && $returnCode == 1 && \ | | | 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 | # check if the return code matched the expected return code set codeFailure 0 if {$processTest && !$setupFailure && ($returnCode ni $returnCodes)} { set codeFailure 1 } set errorCodeFailure 0 if {$processTest && !$setupFailure && !$codeFailure && $returnCode == 1 && \ ![string match $errorCode $errorCodeRes(body)]} { set errorCodeFailure 1 } # If expected output/error strings exist, we have to compare # them. If the comparison fails, then so did the test. set outputFailure 0 variable outData |
︙ | ︙ | |||
2410 2411 2412 2413 2414 2415 2416 | return 1 } } else { # "constraints" argument exists; # make sure that the constraints are satisfied. set doTest 0 | | | 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 | return 1 } } else { # "constraints" argument exists; # make sure that the constraints are satisfied. set doTest 0 set constraints [string trim $constraints] if {[string match {*[$\[]*} $constraints] != 0} { # full expression, e.g. {$foo > [info tclversion]} catch {set doTest [uplevel #0 [list expr $constraints]]} } elseif {[regexp {[^.:_a-zA-Z0-9 \n\r\t]+} $constraints] != 0} { # something like {a || b} should be turned into # $testConstraints(a) || $testConstraints(b). regsub -all {[.\w]+} $constraints {$testConstraints(&)} c |
︙ | ︙ |
Changes to tests/lseq.test.
︙ | ︙ | |||
105 106 107 108 109 110 111 | test lseq-1.15 {count with decreasing step} { -body { lseq 5 count 5 by -2 } -result {5 3 1 -1 -3} } | | > > > > | 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 | test lseq-1.15 {count with decreasing step} { -body { lseq 5 count 5 by -2 } -result {5 3 1 -1 -3} } test lseq-1.16 {large doubles} { -body { lseq [expr {int(1e6)}] [expr {int(2e6)}] [expr {int(1e5)}] } -result {1000000 1100000 1200000 1300000 1400000 1500000 1600000 1700000 1800000 1900000 2000000} } test lseq-1.16.2 {large numbers (bigints are not supported yet)} -body { lseq 0xfffffffffffffffe 0xffffffffffffffff } -returnCodes 1 -result {integer value too large to represent} test lseq-1.17 {too many arguments} -body { lseq 12 to 24 by 2 with feeling } -returnCodes 1 -result {wrong # args: should be "lseq n ??op? n ??by? n??"} test lseq-1.18 {too many arguments extra valid keyword} -body { lseq 12 to 24 by 2 count |
︙ | ︙ | |||
148 149 150 151 152 153 154 155 156 157 158 159 160 161 | list [lseq 0.0 2] [lseq 0 2.0] [lseq 0.0 count 3] \ [lseq 0 count 3 by 1.0] [lseq 0 .. 2.0] [lseq 0 to 2 by 1.0] } [lrepeat 6 {0.0 1.0 2.0}] test lseq-1.25 {consistence, use double (even if representable as integer) in all variants, if contains a double somewhere} { list [lseq double(0) 2] [lseq 0 double(2)] [lseq double(0) count 3] \ [lseq 0 count 3 by double(1)] [lseq 0 .. double(2)] [lseq 0 to 2 by double(1)] } [lrepeat 6 {0.0 1.0 2.0}] # # Short-hand use cases # test lseq-2.2 {step magnitude} { lseq 10 1 2 ;# this is an empty case since step has wrong sign } {} | > > > > > > > > > > > > > > > > | 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 180 181 | list [lseq 0.0 2] [lseq 0 2.0] [lseq 0.0 count 3] \ [lseq 0 count 3 by 1.0] [lseq 0 .. 2.0] [lseq 0 to 2 by 1.0] } [lrepeat 6 {0.0 1.0 2.0}] test lseq-1.25 {consistence, use double (even if representable as integer) in all variants, if contains a double somewhere} { list [lseq double(0) 2] [lseq 0 double(2)] [lseq double(0) count 3] \ [lseq 0 count 3 by double(1)] [lseq 0 .. double(2)] [lseq 0 to 2 by double(1)] } [lrepeat 6 {0.0 1.0 2.0}] test lseq-1.26 {consistence, double always remains double} { list [lseq 1 3.0 ] \ [lseq 1 [expr {3.0+0}] ] \ [lseq 1 {3.0+0} ] \ [lseq 1.0 3.0 1] \ [lseq [expr {1.0+0}] [expr {3.0+0}] 1] \ [lseq {1.0+0} {3.0+0} 1] } [lrepeat 6 {1.0 2.0 3.0}] test lseq-1.27 {consistence, double always remains double} { list [lseq 1e50 [expr {1e50+1}] ] \ [lseq 1e50 {1e50+1} ] \ [lseq [expr {1e50+0}] [expr {1e50+1}] 1] \ [lseq {1e50+0} {1e50+1} 1] \ [lseq [expr {1e50+0}] count 1 1] \ [lseq {1e50+0} count 1 1] } [lrepeat 6 [expr {1e50}]] # # Short-hand use cases # test lseq-2.2 {step magnitude} { lseq 10 1 2 ;# this is an empty case since step has wrong sign } {} |
︙ | ︙ | |||
243 244 245 246 247 248 249 250 251 252 253 254 255 256 | } {{0 1} {2 3 4} {2 3 4 5} {2 6 10} {2 6 10 14}} test lseq-2.20 {expressions as indices, no duplicative eval of expr} { set i 1 list [lseq {[incr i]}] $i [lseq {0 + [incr i]}] $i [lseq {0.0 + [incr i]}] $i } {{0 1} 2 {0 1 2} 3 {0.0 1.0 2.0 3.0} 4} test lseq-3.1 {experiement} -body { set ans {} foreach factor [lseq 2.0 10.0] { set start 1 set end 10 for {set step 1} {$step < 1e8} {} { set l [lseq $start to $end by $step] | > > > > | 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 | } {{0 1} {2 3 4} {2 3 4 5} {2 6 10} {2 6 10 14}} test lseq-2.20 {expressions as indices, no duplicative eval of expr} { set i 1 list [lseq {[incr i]}] $i [lseq {0 + [incr i]}] $i [lseq {0.0 + [incr i]}] $i } {{0 1} 2 {0 1 2} 3 {0.0 1.0 2.0 3.0} 4} test lseq-3.0 {expr error: don't swalow expr error (here: divide by zero)} -body { set i 0; lseq {3/$i} } -returnCodes [catch {expr {3/0}} res] -result $res test lseq-3.1 {experiement} -body { set ans {} foreach factor [lseq 2.0 10.0] { set start 1 set end 10 for {set step 1} {$step < 1e8} {} { set l [lseq $start to $end by $step] |
︙ | ︙ | |||
267 268 269 270 271 272 273 | set ans } -cleanup { unset ans step end start factor l } -result {OK} test lseq-3.2 {error case} -body { lseq foo | | | | > > > | 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 321 322 323 324 325 326 | set ans } -cleanup { unset ans step end start factor l } -result {OK} test lseq-3.2 {error case} -body { lseq foo } -returnCodes 1 -match glob -result {invalid bareword "foo"*} test lseq-3.3 {error case} -body { lseq 10 foo } -returnCodes 1 -match glob -result {invalid bareword "foo"*} test lseq-3.4 {error case} -body { lseq 25 or 6 } -returnCodes 1 -match glob -result {invalid bareword "or"*} test lseq-3.5 {simple count and step arguments} -body { set s [lseq 25 by 6] list $s length=[llength $s] } -cleanup { unset s } -result {{0 6 12 18 24 30 36 42 48 54 60 66 72 78 84 90 96 102 108 114 120 126 132 138 144} length=25} test lseq-3.6 {error case} -body { lseq 1 7 or 3 } -returnCodes 1 -result {bad operation "or": must be .., to, count, or by} test lseq-3.6b {error case} -body { lseq 1 to 7 or 3 } -returnCodes 1 -result {bad operation "or": must be .., to, count, or by} test lseq-3.7 {lmap lseq} -body { lmap x [lseq 5] { expr {$x * $x} } } -cleanup {unset x} -result {0 1 4 9 16} test lseq-3.8 {lrange lseq} -body { |
︙ | ︙ |
Changes to tests/remote.tcl.
︙ | ︙ | |||
36 37 38 39 40 41 42 | } proc __readAndExecute__ {s} { global command VERBOSE set l [gets $s] if {[string compare $l "--Marker--Marker--Marker--"] == 0} { | | | | | | 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 | } proc __readAndExecute__ {s} { global command VERBOSE set l [gets $s] if {[string compare $l "--Marker--Marker--Marker--"] == 0} { puts $s [__doCommands__ $command($s) $s] puts $s "--Marker--Marker--Marker--" set command($s) "" return } if {[string compare $l ""] == 0} { if {[eof $s]} { if {$VERBOSE} { puts "Server closing $s, eof from client" } close $s } return } if {[eof $s]} { if {$VERBOSE} { puts "Server closing $s, eof from client" } close $s unset command($s) return } append command($s) $l "\n" } proc __accept__ {s a p} { global command VERBOSE |
︙ | ︙ |