Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Changes In Branch internal-ensemble-cleanup Excluding Merge-Ins
This is equivalent to a diff from b6800b76c8 to ad795c4db6
|
2025-11-11
| ||
| 20:26 | Refactor core ensemble creation/management so that the tables describing what's there and what's saf... check-in: a165eede1d user: dkf tags: trunk, main | |
| 09:29 | Merge 9.0 check-in: 2f1c224732 user: jan.nijtmans tags: trunk, main | |
|
2025-11-10
| ||
| 17:03 | merge trunk Closed-Leaf check-in: ad795c4db6 user: dkf tags: internal-ensemble-cleanup | |
| 17:00 | merge trunk Closed-Leaf check-in: 2491dad7a7 user: dkf tags: c11-tebc-trace-cleanup | |
| 15:09 | merge trunk check-in: 7ffebdfab0 user: dkf tags: enums-3 | |
| 14:02 | Name three related enums in a consistent way check-in: b6800b76c8 user: dkf tags: trunk, main | |
|
2025-11-09
| ||
| 11:16 | merge trunk check-in: fcad76bb7d user: dkf tags: internal-ensemble-cleanup | |
| 09:57 | Merge 9.0. Bug [cb03e57a] - raise error on empty regexp for unresolved variable. check-in: 2ab1a13679 user: apnadkarni tags: trunk, main | |
Changes to generic/tclBasic.c.
| ︙ | ︙ | |||
163 164 165 166 167 168 169 170 171 172 173 174 175 176 |
iPtr->lineLABCPtr = (context).lineLABCPtr
/*
* Static functions in this file:
*/
static Tcl_ObjCmdProc BadEnsembleSubcommand;
static char * CallCommandTraces(Interp *iPtr, Command *cmdPtr,
const char *oldName, const char *newName,
int flags);
static int CancelEvalProc(void *clientData,
Tcl_Interp *interp, int code);
static int CheckDoubleResult(Tcl_Interp *interp, double dResult);
static void DeleteCoroutine(void *clientData);
| > | 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 |
iPtr->lineLABCPtr = (context).lineLABCPtr
/*
* Static functions in this file:
*/
static Tcl_ObjCmdProc BadEnsembleSubcommand;
static Tcl_CmdDeleteProc BadEnsembleSubcommandCleanup;
static char * CallCommandTraces(Interp *iPtr, Command *cmdPtr,
const char *oldName, const char *newName,
int flags);
static int CancelEvalProc(void *clientData,
Tcl_Interp *interp, int code);
static int CheckDoubleResult(Tcl_Interp *interp, double dResult);
static void DeleteCoroutine(void *clientData);
|
| ︙ | ︙ | |||
254 255 256 257 258 259 260 |
};
/*
* The following structure define the commands in the Tcl core.
*/
typedef struct {
| | | | | | < < < < | > > > > > > > > > > > > | | < | | > | | | | | 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 |
};
/*
* The following structure define the commands in the Tcl core.
*/
typedef struct {
const char *name; // Name of object-based command.
Tcl_ObjCmdProc *objProc; // Object-based function for command.
CompileProc *compileProc; // Function called to compile command.
Tcl_ObjCmdProc *nreProc; // NR-based function for command.
int flags; // Various flag bits, as defined below.
} CmdInfo;
enum CmdInfoFlags {
CMD_IS_SAFE = 1 /* Whether this command is part of the set of
* commands present by default in a safe
* interpreter. */
/* CMD_COMPILES_EXPANDED - Whether the compiler for this command can handle
* expansion for itself rather than needing the generic layer to take care of
* it for it. Defined in tclInt.h. */
};
/*
* Description of commands in ::tcl::unsupported.
*
*/
typedef struct UnsupportedCmdInfo {
const char *name; // Name of command in ::tcl::unsupported.
Tcl_ObjCmdProc *objProc; // Object-based function for command.
CompileProc *compileProc; // Function called to compile command.
Tcl_ObjCmdProc *nreProc; // NR-based function for command.
void *clientData; // ClientData to use for the command.
int flags; // Various flag bits, as defined for CmdInfo.
} UnsupportedCmdInfo;
// A function that can configure an ensemble after it is created.
typedef int (EnsembleConfigurer)(Tcl_Interp *interp, Tcl_Command ensemble);
typedef struct EnsembleSetup {
const char *name; // Name of ensemble.
const EnsembleImplMap *implMap; // Ensemble contents descriptor.
EnsembleConfigurer *configurerProc; // Optional callback for customisation.
int flags; /* Ensemble commands are never technically
* unsafe (though their subcommands may well
* be so), but some code expects them to be
* so. This flag lets us mark those cases. */
} EnsembleSetup;
/*
* The built-in commands, and the functions that implement them:
*/
static int
ProcObjCmd(
|
| ︙ | ︙ | |||
404 405 406 407 408 409 410 |
{"timerate", Tcl_TimeRateObjCmd, NULL, NULL, CMD_IS_SAFE},
{"unload", Tcl_UnloadObjCmd, NULL, NULL, 0},
{"update", Tcl_UpdateObjCmd, NULL, NULL, CMD_IS_SAFE},
{"vwait", Tcl_VwaitObjCmd, NULL, NULL, CMD_IS_SAFE},
{NULL, NULL, NULL, NULL, 0}
};
| < > | | < | < < < > | < < < < > | < < | < < < < < < < < < < < < < < < < < < < | | | | | | | | > > > > | < | | > | | < < < < | < < | < < < < < < < < < < < < < > | | 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 |
{"timerate", Tcl_TimeRateObjCmd, NULL, NULL, CMD_IS_SAFE},
{"unload", Tcl_UnloadObjCmd, NULL, NULL, 0},
{"update", Tcl_UpdateObjCmd, NULL, NULL, CMD_IS_SAFE},
{"vwait", Tcl_VwaitObjCmd, NULL, NULL, CMD_IS_SAFE},
{NULL, NULL, NULL, NULL, 0}
};
static const UnsupportedCmdInfo unsupportedCmds[] = {
{"disassemble", Tcl_DisassembleObjCmd, NULL, NULL, INT2PTR(0), 0},
{"getbytecode", Tcl_DisassembleObjCmd, NULL, NULL, INT2PTR(1), 0},
{"representation", Tcl_RepresentationCmd, NULL, NULL, NULL, 0},
{"assemble", Tcl_AssembleObjCmd, TclCompileAssembleCmd, TclNRAssembleObjCmd, NULL, CMD_IS_SAFE},
{"corotype", CoroTypeObjCmd, NULL, NULL, NULL, CMD_IS_SAFE},
{"loadIcu", TclLoadIcuObjCmd, NULL, NULL, NULL, 0}, // TODO: Is this supposed to be callable from safe interps?
{NULL, NULL, NULL, NULL, NULL, 0}
};
// Table of definitions of ensemble commands.
static const EnsembleSetup ensembleCommands[] = {
{"array", tclArrayImplMap, NULL, CMD_IS_SAFE},
{"binary", tclBinaryImplMap, NULL, CMD_IS_SAFE},
{"binary encode", tclBinaryEncodeImplMap, NULL, CMD_IS_SAFE},
{"binary decode", tclBinaryDecodeImplMap, NULL, CMD_IS_SAFE},
{"chan", tclChanImplMap, TclSetUpChanCmd, CMD_IS_SAFE},
// TODO: Sort out why setup of [clock] is so weird
{"clock", tclClockImplMap, NULL, 0},
{"dict", tclDictImplMap, NULL, CMD_IS_SAFE},
{"encoding", tclEncodingImplMap, NULL, 0},
{"file", tclFileImplMap, NULL, 0},
{"info", tclInfoImplMap, NULL, CMD_IS_SAFE},
{"namespace", tclNamespaceImplMap, NULL, CMD_IS_SAFE},
{"string", tclStringImplMap, NULL, CMD_IS_SAFE},
{"::tcl::prefix", tclPrefixImplMap, TclSetUpPrefixCmd, CMD_IS_SAFE},
{"::tcl::process", tclProcessImplMap, TclSetUpProcessCmd, CMD_IS_SAFE},
{"unicode", tclUnicodeImplMap, NULL, CMD_IS_SAFE},
{"zipfs", tclZipfsImplMap, NULL, 0},
{"zlib", tclZlibImplMap, NULL, CMD_IS_SAFE},
{NULL, NULL, NULL, 0}
};
/*
* Math functions. All are safe.
*/
typedef double (BuiltinUnaryFunc)(double x);
|
| ︙ | ︙ | |||
1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 |
iPtr->allocCache = (AllocCache *)TclpGetAllocCache();
#else
iPtr->allocCache = NULL;
#endif
iPtr->pendingObjDataPtr = NULL;
iPtr->asyncReadyPtr = TclGetAsyncReadyPtr();
iPtr->deferredCallbacks = NULL;
/*
* Create the core commands. Do it here, rather than calling Tcl_CreateObjCommand,
* because it's faster (there's no need to check for a preexisting command
* by the same name). Set the Tcl_CmdProc to NULL.
*/
| > > > > > > > | 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 |
iPtr->allocCache = (AllocCache *)TclpGetAllocCache();
#else
iPtr->allocCache = NULL;
#endif
iPtr->pendingObjDataPtr = NULL;
iPtr->asyncReadyPtr = TclGetAsyncReadyPtr();
iPtr->deferredCallbacks = NULL;
// Create the namespace for unsupported bits and pieces.
Tcl_Namespace *unsupportedNs = Tcl_CreateNamespace(interp,
"::tcl::unsupported", NULL, NULL);
if (unsupportedNs == NULL) {
Tcl_Panic("couldn't find ::tcl::unsupported");
}
/*
* Create the core commands. Do it here, rather than calling Tcl_CreateObjCommand,
* because it's faster (there's no need to check for a preexisting command
* by the same name). Set the Tcl_CmdProc to NULL.
*/
|
| ︙ | ︙ | |||
1144 1145 1146 1147 1148 1149 1150 |
cmdPtr->tracePtr = NULL;
cmdPtr->nreProc = cmdInfoPtr->nreProc;
Tcl_SetHashValue(hPtr, cmdPtr);
}
}
/*
| | | | | | | | | | < < | > | < < < > > > | 1119 1120 1121 1122 1123 1124 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 |
cmdPtr->tracePtr = NULL;
cmdPtr->nreProc = cmdInfoPtr->nreProc;
Tcl_SetHashValue(hPtr, cmdPtr);
}
}
/*
* Create the standard ensembles "array", "binary", "chan", "clock",
* "dict", "encoding", "file", "info", "namespace", "string", etc. Note
* that most of these commands (and their subcommands that are not present
* in the global namespace) are wholly safe *except* as marked.
*/
const EnsembleSetup *ensSetupPtr;
for (ensSetupPtr=ensembleCommands; ensSetupPtr->name; ensSetupPtr++) {
Tcl_Command ensemble = TclMakeEnsemble(interp, ensSetupPtr->name,
ensSetupPtr->implMap);
if (ensSetupPtr->configurerProc) {
if (ensSetupPtr->configurerProc(interp, ensemble) != TCL_OK) {
Tcl_Panic("failed to set up %s: %s", ensSetupPtr->name,
Tcl_GetStringResult(interp));
}
}
}
/*
* Register "clock" subcommands. These *do* go through
* Tcl_CreateObjCommand, since they aren't in the global namespace and
* involve ensembles.
*/
|
| ︙ | ︙ | |||
1187 1188 1189 1190 1191 1192 1193 |
Tcl_CreateObjCommand(interp, "::tcl::Bgerror",
TclDefaultBgErrorHandlerObjCmd, NULL, NULL);
/*
* Create unsupported commands for debugging bytecode and objects.
*/
| | < < < < < | < | | | < | < < < | < < < | < < < | < | | 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 |
Tcl_CreateObjCommand(interp, "::tcl::Bgerror",
TclDefaultBgErrorHandlerObjCmd, NULL, NULL);
/*
* Create unsupported commands for debugging bytecode and objects.
*/
const UnsupportedCmdInfo *unsCmdInfoPtr;
for (unsCmdInfoPtr=unsupportedCmds; unsCmdInfoPtr->name; unsCmdInfoPtr++) {
cmdPtr = (Command *) TclCreateObjCommandInNs(interp,
unsCmdInfoPtr->name, unsupportedNs, unsCmdInfoPtr->objProc,
unsCmdInfoPtr->clientData, NULL);
cmdPtr->nreProc = unsCmdInfoPtr->nreProc;
cmdPtr->compileProc = unsCmdInfoPtr->compileProc;
}
Tcl_Export(interp, unsupportedNs, "*", 1);
#ifdef USE_DTRACE
/*
* Register the tcl::dtrace command.
*/
Tcl_CreateObjCommand(interp, "::tcl::dtrace", DTraceObjCmd, NULL, NULL);
#endif /* USE_DTRACE */
/*
* Register the builtin math functions.
*/
nsPtr = Tcl_CreateNamespace(interp, "::tcl::mathfunc", NULL, NULL);
if (nsPtr == NULL) {
Tcl_Panic("Can't create math function namespace");
}
#define MATH_FUNC_PREFIX_LEN 17 /* == strlen("::tcl::mathfunc::") */
memcpy(mathFuncName, "::tcl::mathfunc::", MATH_FUNC_PREFIX_LEN);
for (builtinFuncPtr = BuiltinFuncTable; builtinFuncPtr->name != NULL;
builtinFuncPtr++) {
|
| ︙ | ︙ | |||
1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 |
* TCL_OK if it succeeds, TCL_ERROR else.
*
* Side effects:
* Hides functionality in an interpreter.
*
*----------------------------------------------------------------------
*/
int
TclHideUnsafeCommands(
Tcl_Interp *interp) /* Hide commands in this interpreter. */
{
const CmdInfo *cmdInfoPtr;
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > | | | > > < | < | | < | | < | | < | | | | < < < < > | > | < < < < < | > > > > | 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 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 1438 1439 1440 1441 1442 1443 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 |
* TCL_OK if it succeeds, TCL_ERROR else.
*
* Side effects:
* Hides functionality in an interpreter.
*
*----------------------------------------------------------------------
*/
static void
HideCommandInTclNs(
Tcl_Interp *interp,
const char *nsName,
const char *name,
Tcl_Obj *publicNameTuple)
{
Tcl_Obj *cmdName = Tcl_ObjPrintf("::tcl::%s::%s", nsName, name);
Tcl_Obj *hideName = Tcl_ObjPrintf("tcl:%s:%s", nsName, name);
#define INTERIM_HACK_NAME "___tmp"
// TODO: Fix the hiding machinery to handle namespaced commands.
if (TclRenameCommand(interp, TclGetString(cmdName),
INTERIM_HACK_NAME) != TCL_OK
|| Tcl_HideCommand(interp, INTERIM_HACK_NAME,
TclGetString(hideName)) != TCL_OK) {
Tcl_Panic("problem making '%s %s' safe: %s",
nsName, name, Tcl_GetStringResult(interp));
}
if (publicNameTuple) {
Tcl_IncrRefCount(publicNameTuple);
Tcl_CreateObjCommand(interp, TclGetString(cmdName),
BadEnsembleSubcommand, (void *)publicNameTuple,
BadEnsembleSubcommandCleanup);
}
TclDecrRefCount(cmdName);
TclDecrRefCount(hideName);
}
int
TclHideUnsafeCommands(
Tcl_Interp *interp) /* Hide commands in this interpreter. */
{
const CmdInfo *cmdInfoPtr;
const EnsembleSetup *ensSetupPtr;
const EnsembleImplMap *implMapPtr;
const UnsupportedCmdInfo *unsCmdInfoPtr;
if (interp == NULL) {
return TCL_ERROR;
}
for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; cmdInfoPtr++) {
if (!(cmdInfoPtr->flags & CMD_IS_SAFE)) {
Tcl_HideCommand(interp, cmdInfoPtr->name, cmdInfoPtr->name);
}
}
for (ensSetupPtr = ensembleCommands; ensSetupPtr->name; ensSetupPtr++) {
for (implMapPtr=ensSetupPtr->implMap; implMapPtr->name; implMapPtr++) {
if (!implMapPtr->unsafe) {
continue;
}
/*
* Hide an ensemble subcommand.
*/
const char *ensembleNsName = ensSetupPtr->name, *sub;
while ((sub = strstr(ensembleNsName, "::")) != NULL) {
ensembleNsName = sub + 2;
}
HideCommandInTclNs(interp, ensembleNsName, implMapPtr->name,
Tcl_NewListObj(2, ((Tcl_Obj*[]) {
Tcl_NewStringObj(ensSetupPtr->name, TCL_AUTO_LENGTH),
Tcl_NewStringObj(implMapPtr->name, TCL_AUTO_LENGTH)
})));
}
if (!(ensSetupPtr->flags & CMD_IS_SAFE)) {
/*
* Hide a main command (for compatibility).
*/
Tcl_HideCommand(interp, ensSetupPtr->name, ensSetupPtr->name);
}
}
for (unsCmdInfoPtr=unsupportedCmds; unsCmdInfoPtr->name; unsCmdInfoPtr++) {
if (!(unsCmdInfoPtr->flags & CMD_IS_SAFE)) {
HideCommandInTclNs(interp, "unsupported", unsCmdInfoPtr->name, NULL);
}
}
return TCL_OK;
}
/*
|
| ︙ | ︙ | |||
1518 1519 1520 1521 1522 1523 1524 |
static int
BadEnsembleSubcommand(
void *clientData,
Tcl_Interp *interp,
TCL_UNUSED(int) /*objc*/,
TCL_UNUSED(Tcl_Obj *const *) /* objv */)
{
| | > > | > > > > > > > > > > > > > > > > > > > > > > > > > | 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 |
static int
BadEnsembleSubcommand(
void *clientData,
Tcl_Interp *interp,
TCL_UNUSED(int) /*objc*/,
TCL_UNUSED(Tcl_Obj *const *) /* objv */)
{
Tcl_Obj *publicNameTuple = (Tcl_Obj *)clientData;
Tcl_Obj *ensembleName = TclListObjGetElement(publicNameTuple, 0);
Tcl_Obj *commandName = TclListObjGetElement(publicNameTuple, 1);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"not allowed to invoke subcommand %s of %s",
TclGetString(commandName), TclGetString(ensembleName)));
Tcl_SetErrorCode(interp, "TCL", "SAFE", "SUBCOMMAND", (char *)NULL);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* BadEnsembleSubcommandCleanup --
*
* Cleans up data used by BadEnsembleSubcommand() when an instance of it
* is deleted.
*
* Results:
* None.
*
* Side effects:
* Releases a memory reference.
*
*----------------------------------------------------------------------
*/
static void
BadEnsembleSubcommandCleanup(
void *clientData)
{
Tcl_Obj *publicNameTuple = (Tcl_Obj *)clientData;
Tcl_DecrRefCount(publicNameTuple);
}
/*
*--------------------------------------------------------------
*
* Tcl_CallWhenDeleted --
*
* Arrange for a function to be called before a given interpreter is
|
| ︙ | ︙ |
Changes to generic/tclBinary.c.
| ︙ | ︙ | |||
116 117 118 119 120 121 122 |
'='
};
/*
* How to construct the ensembles.
*/
| | | | | | 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 |
'='
};
/*
* How to construct the ensembles.
*/
const EnsembleImplMap tclBinaryImplMap[] = {
{ "format", BinaryFormatCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0 },
{ "scan", BinaryScanCmd, TclCompileBasicMin2ArgCmd, NULL, NULL, 0 }, // TODO: compile?
{ "encode", NULL, NULL, NULL, NULL, 0 },
{ "decode", NULL, NULL, NULL, NULL, 0 },
{ NULL, NULL, NULL, NULL, NULL, 0 }
};
const EnsembleImplMap tclBinaryEncodeImplMap[] = {
{ "hex", BinaryEncodeHex, TclCompileBasic1ArgCmd, NULL, NULL, 0 },
{ "uuencode", BinaryEncodeUu, NULL, NULL, NULL, 0 },
{ "base64", BinaryEncode64, NULL, NULL, NULL, 0 },
{ NULL, NULL, NULL, NULL, NULL, 0 }
};
const EnsembleImplMap tclBinaryDecodeImplMap[] = {
{ "hex", BinaryDecodeHex, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0 },
{ "uuencode", BinaryDecodeUu, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0 },
{ "base64", BinaryDecode64, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0 },
{ NULL, NULL, NULL, NULL, NULL, 0 }
};
/*
|
| ︙ | ︙ | |||
780 781 782 783 784 785 786 |
if (bytes) {
memcpy(byteArrayPtr->bytes + byteArrayPtr->used, bytes, len);
}
byteArrayPtr->used += len;
TclInvalidateStringRep(objPtr);
}
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 780 781 782 783 784 785 786 787 788 789 790 791 792 793 |
if (bytes) {
memcpy(byteArrayPtr->bytes + byteArrayPtr->used, bytes, len);
}
byteArrayPtr->used += len;
TclInvalidateStringRep(objPtr);
}
/*
*----------------------------------------------------------------------
*
* BinaryFormatCmd --
*
* This procedure implements the "binary format" Tcl command.
|
| ︙ | ︙ |
Changes to generic/tclClock.c.
| ︙ | ︙ | |||
18 19 20 21 22 23 24 25 26 27 28 29 30 31 |
#include "tclTomMath.h"
#include "tclStrIdxTree.h"
#include "tclDate.h"
#if defined(_WIN32) && defined (__clang__) && (__clang_major__ > 20)
#pragma clang diagnostic ignored "-Wc++-keyword"
#endif
/*
* Table of the days in each month, leap and common years
*/
static const int hath[2][12] = {
{31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31},
{31, 29, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31}
| > > > | 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 |
#include "tclTomMath.h"
#include "tclStrIdxTree.h"
#include "tclDate.h"
#if defined(_WIN32) && defined (__clang__) && (__clang_major__ > 20)
#pragma clang diagnostic ignored "-Wc++-keyword"
#endif
/* The namespace containing the [clock] internals. */
#define TCL_CLOCK_NS "::tcl::clock"
/*
* Table of the days in each month, leap and common years
*/
static const int hath[2][12] = {
{31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31},
{31, 29, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31}
|
| ︙ | ︙ | |||
110 111 112 113 114 115 116 117 118 119 | static Tcl_ObjCmdProc ClockAddObjCmd; static int ClockValidDate(DateInfo *, ClockFmtScnCmdArgs *, int stage); static struct tm * ThreadSafeLocalTime(const time_t *); static size_t TzsetIfNecessary(void); static void ClockDeleteCmdProc(void *); static void ClockFinalize(void *); /* * Structure containing description of "native" clock commands to create. */ | > < | | > > > > > | < | | < < | < | | | | | > > > > > > > > > > > > > > > > > > | | 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 |
static Tcl_ObjCmdProc ClockAddObjCmd;
static int ClockValidDate(DateInfo *,
ClockFmtScnCmdArgs *, int stage);
static struct tm * ThreadSafeLocalTime(const time_t *);
static size_t TzsetIfNecessary(void);
static void ClockDeleteCmdProc(void *);
static void ClockFinalize(void *);
/*
* Structure containing description of "native" clock commands to create.
*/
struct ClockCommand {
const char *name; /* The tail of the command name. The full name
* is "::tcl::clock::<name>". When NULL marks
* the end of the table. */
Tcl_ObjCmdProc *objCmdProc; /* Function that implements the command. This
* will always have the ClockClientData sent
* to it, but may well ignore this data. */
CompileProc *compileProc; /* The compiler for the command. */
int useClientData; /* Whether to use the shared ClockClientData
* with this command. */
};
/*
* Table of command created by this file, excluding the compiled parts of the
* [clock] ensemble, as those are defined below (and never need access to the
* ClockClientData).
*/
static const struct ClockCommand clockCommands[] = {
{"add", ClockAddObjCmd, TclCompileBasicMin1ArgCmd, 1},
{"format", ClockFormatObjCmd, TclCompileBasicMin1ArgCmd, 1},
{"getenv", ClockGetenvObjCmd, NULL, 1},
{"scan", ClockScanObjCmd, TclCompileBasicMin1ArgCmd, 1},
{"ConvertLocalToUTC", ClockConvertlocaltoutcObjCmd, NULL, 1},
{"GetDateFields", ClockGetdatefieldsObjCmd, NULL, 1},
{"GetJulianDayFromEraYearMonthDay",
ClockGetjuliandayfromerayearmonthdayObjCmd, NULL, 1},
{"GetJulianDayFromEraYearWeekDay",
ClockGetjuliandayfromerayearweekdayObjCmd, NULL, 1},
{"catch", TclSafeCatchCmd, NULL, 0},
{NULL, NULL, NULL, 0}
};
/*
* Definition of the [clock] ensemble.
*
* [clock add], [clock format] and [clock scan] have special clientData, so
* we just tell the ensemble that they'll be there instead of maxing them at
* this point.
*/
const EnsembleImplMap tclClockImplMap[] = {
{"add", NULL, NULL, NULL, NULL, 1},
{"clicks", ClockClicksObjCmd, TclCompileClockClicksCmd, NULL, NULL, 0},
{"format", NULL, NULL, NULL, NULL, 1},
{"microseconds", ClockMicrosecondsObjCmd,TclCompileClockReadingCmd, NULL, INT2PTR(CLOCK_READ_MICROS), 0},
{"milliseconds", ClockMillisecondsObjCmd,TclCompileClockReadingCmd, NULL, INT2PTR(CLOCK_READ_MILLIS), 0},
{"scan", NULL, NULL, NULL, NULL, 1},
{"seconds", ClockSecondsObjCmd, TclCompileClockReadingCmd, NULL, INT2PTR(CLOCK_READ_SECS), 0},
{NULL, NULL, NULL, NULL, NULL, 0}
};
/*
*----------------------------------------------------------------------
*
* TclClockInit --
*
|
| ︙ | ︙ | |||
167 168 169 170 171 172 173 |
*----------------------------------------------------------------------
*/
void
TclClockInit(
Tcl_Interp *interp) /* Tcl interpreter */
{
| < < < < < < | < | 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 |
*----------------------------------------------------------------------
*/
void
TclClockInit(
Tcl_Interp *interp) /* Tcl interpreter */
{
static int initialized = 0; /* global clock engine initialized (in process) */
/*
* Register handler to finalize clock on exit.
*/
if (!initialized) {
Tcl_CreateExitHandler(ClockFinalize, NULL);
initialized = 1;
}
|
| ︙ | ︙ | |||
197 198 199 200 201 202 203 |
return;
}
/*
* Create the client data, which is a refcounted literal pool.
*/
| | > | 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 |
return;
}
/*
* Create the client data, which is a refcounted literal pool.
*/
ClockClientData *data = (ClockClientData *)Tcl_Alloc(sizeof(ClockClientData));
data->refCount = 0;
data->literals = (Tcl_Obj **)Tcl_Alloc(LIT__END * sizeof(Tcl_Obj*));
int i;
for (i = 0; i < LIT__END; ++i) {
TclInitObjRef(data->literals[i], Tcl_NewStringObj(
Literals[i], TCL_AUTO_LENGTH));
}
data->mcLiterals = NULL;
data->mcLitIdxs = NULL;
data->mcDicts = NULL;
|
| ︙ | ︙ | |||
249 250 251 252 253 254 255 |
data->defFlags = CLF_VALIDATE;
/*
* Install the commands.
*/
| | | | | < < | | | | < < | < | 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 |
data->defFlags = CLF_VALIDATE;
/*
* Install the commands.
*/
Tcl_Namespace *nsPtr = Tcl_FindNamespace(interp, TCL_CLOCK_NS, NULL, 0);
const struct ClockCommand *clockCmdPtr;
for (clockCmdPtr=clockCommands ; clockCmdPtr->name!=NULL ; clockCmdPtr++) {
void *clientData = NULL;
if (clockCmdPtr->useClientData) {
clientData = data;
data->refCount++;
}
Command *cmdPtr = (Command *)TclCreateObjCommandInNs(interp,
clockCmdPtr->name, nsPtr, clockCmdPtr->objCmdProc, clientData,
clientData ? ClockDeleteCmdProc : NULL);
cmdPtr->compileProc = clockCmdPtr->compileProc;
}
Tcl_CreateObjCommand(interp, "::tcl::unsupported::clock::configure",
ClockConfigureObjCmd, data, ClockDeleteCmdProc);
data->refCount++;
}
/*
*----------------------------------------------------------------------
*
* ClockConfigureClear --
*
|
| ︙ | ︙ | |||
955 956 957 958 959 960 961 |
void *clientData, /* Client data containing literal pool */
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const objv[]) /* Parameter vector */
{
ClockClientData *dataPtr = (ClockClientData *)clientData;
static const char *const options[] = {
| | | | | | | 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 |
void *clientData, /* Client data containing literal pool */
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const objv[]) /* Parameter vector */
{
ClockClientData *dataPtr = (ClockClientData *)clientData;
static const char *const options[] = {
"-default-locale", "-clear", "-current-locale",
"-year-century", "-century-switch",
"-min-year", "-max-year", "-max-jdn",
"-validate", "-setup-tz", "-system-tz", NULL
};
enum optionInd {
CLOCK_DEFAULT_LOCALE, CLOCK_CLEAR_CACHE, CLOCK_CURRENT_LOCALE,
CLOCK_YEAR_CENTURY, CLOCK_CENTURY_SWITCH,
CLOCK_MIN_YEAR, CLOCK_MAX_YEAR, CLOCK_MAX_JDN, CLOCK_VALIDATE,
CLOCK_SETUP_TZ, CLOCK_SYSTEM_TZ
};
int optionIndex; /* Index of an option. */
Tcl_Size i;
for (i = 1; i < objc; i++) {
if (Tcl_GetIndexFromObj(interp, objv[i++], options,
"option", 0, &optionIndex) != TCL_OK) {
|
| ︙ | ︙ | |||
1136 1137 1138 1139 1140 1141 1142 | Tcl_SetObjResult(interp, Tcl_NewBooleanObj(dataPtr->defFlags & CLF_VALIDATE)); } break; case CLOCK_CLEAR_CACHE: ClockConfigureClear(dataPtr); break; | < < < < < < < < < < < < < < < < < < < < | 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 |
Tcl_SetObjResult(interp,
Tcl_NewBooleanObj(dataPtr->defFlags & CLF_VALIDATE));
}
break;
case CLOCK_CLEAR_CACHE:
ClockConfigureClear(dataPtr);
break;
default:
TCL_UNREACHABLE();
}
}
return TCL_OK;
}
|
| ︙ | ︙ | |||
1414 1415 1416 1417 1418 1419 1420 |
{
ClockClientData *dataPtr = (ClockClientData *)clientData;
Tcl_Obj *secondsObj;
Tcl_Obj *dict;
int changeover;
TclDateFields fields;
int created = 0;
| < | 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 |
{
ClockClientData *dataPtr = (ClockClientData *)clientData;
Tcl_Obj *secondsObj;
Tcl_Obj *dict;
int changeover;
TclDateFields fields;
int created = 0;
fields.tzName = NULL;
/*
* Check params and convert time.
*/
if (objc != 4) {
|
| ︙ | ︙ | |||
1451 1452 1453 1454 1455 1456 1457 |
*/
if (Tcl_IsShared(dict)) {
dict = Tcl_DuplicateObj(dict);
created = 1;
Tcl_IncrRefCount(dict);
}
| | | | | 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 |
*/
if (Tcl_IsShared(dict)) {
dict = Tcl_DuplicateObj(dict);
created = 1;
Tcl_IncrRefCount(dict);
}
int result = Tcl_DictObjPut(interp, dict, dataPtr->literals[LIT_SECONDS],
Tcl_NewWideIntObj(fields.seconds));
if (result == TCL_OK) {
Tcl_SetObjResult(interp, dict);
}
if (created) {
Tcl_DecrRefCount(dict);
}
return result;
}
/*
*----------------------------------------------------------------------
*
* ClockGetdatefieldsObjCmd --
*
|
| ︙ | ︙ | |||
1698 1699 1700 1701 1702 1703 1704 |
{
TclDateFields fields;
Tcl_Obj *dict;
ClockClientData *data = (ClockClientData *)clientData;
Tcl_Obj *const *lit = data->literals;
int changeover;
int copied = 0;
| < | 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 |
{
TclDateFields fields;
Tcl_Obj *dict;
ClockClientData *data = (ClockClientData *)clientData;
Tcl_Obj *const *lit = data->literals;
int changeover;
int copied = 0;
int isBce = 0;
fields.tzName = NULL;
/*
* Check params.
*/
|
| ︙ | ︙ | |||
1739 1740 1741 1742 1743 1744 1745 |
*/
if (Tcl_IsShared(dict)) {
dict = Tcl_DuplicateObj(dict);
Tcl_IncrRefCount(dict);
copied = 1;
}
| | | | | 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 |
*/
if (Tcl_IsShared(dict)) {
dict = Tcl_DuplicateObj(dict);
Tcl_IncrRefCount(dict);
copied = 1;
}
int result = Tcl_DictObjPut(interp, dict, lit[LIT_JULIANDAY],
Tcl_NewWideIntObj(fields.julianDay));
if (result == TCL_OK) {
Tcl_SetObjResult(interp, dict);
}
if (copied) {
Tcl_DecrRefCount(dict);
}
return result;
}
/*
*----------------------------------------------------------------------
*
* ClockGetjuliandayfromerayearweekdayObjCmd --
*
|
| ︙ | ︙ | |||
1784 1785 1786 1787 1788 1789 1790 |
{
TclDateFields fields;
Tcl_Obj *dict;
ClockClientData *data = (ClockClientData *)clientData;
Tcl_Obj *const *lit = data->literals;
int changeover;
int copied = 0;
| < | 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 |
{
TclDateFields fields;
Tcl_Obj *dict;
ClockClientData *data = (ClockClientData *)clientData;
Tcl_Obj *const *lit = data->literals;
int changeover;
int copied = 0;
int isBce = 0;
fields.tzName = NULL;
/*
* Check params.
*/
|
| ︙ | ︙ | |||
1825 1826 1827 1828 1829 1830 1831 |
*/
if (Tcl_IsShared(dict)) {
dict = Tcl_DuplicateObj(dict);
Tcl_IncrRefCount(dict);
copied = 1;
}
| | | | | 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 |
*/
if (Tcl_IsShared(dict)) {
dict = Tcl_DuplicateObj(dict);
Tcl_IncrRefCount(dict);
copied = 1;
}
int result = Tcl_DictObjPut(interp, dict, lit[LIT_JULIANDAY],
Tcl_NewWideIntObj(fields.julianDay));
if (result == TCL_OK) {
Tcl_SetObjResult(interp, dict);
}
if (copied) {
Tcl_DecrRefCount(dict);
}
return result;
}
/*
*----------------------------------------------------------------------
*
* ConvertLocalToUTC --
*
|
| ︙ | ︙ |
Changes to generic/tclCmdAH.c.
| ︙ | ︙ | |||
95 96 97 98 99 100 101 102 103 104 105 106 107 108 | static Tcl_ObjCmdProc PathJoinCmd; static Tcl_ObjCmdProc PathNativeNameCmd; static Tcl_ObjCmdProc PathNormalizeCmd; static Tcl_ObjCmdProc PathRootNameCmd; static Tcl_ObjCmdProc PathSplitCmd; static Tcl_ObjCmdProc PathTailCmd; static Tcl_ObjCmdProc PathTypeCmd; /* *---------------------------------------------------------------------- * * Tcl_BreakObjCmd -- * * This procedure is invoked to process the "break" Tcl command. See the | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 |
static Tcl_ObjCmdProc PathJoinCmd;
static Tcl_ObjCmdProc PathNativeNameCmd;
static Tcl_ObjCmdProc PathNormalizeCmd;
static Tcl_ObjCmdProc PathRootNameCmd;
static Tcl_ObjCmdProc PathSplitCmd;
static Tcl_ObjCmdProc PathTailCmd;
static Tcl_ObjCmdProc PathTypeCmd;
const EnsembleImplMap tclEncodingImplMap[] = {
{"convertfrom", EncodingConvertfromObjCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 0},
{"convertto", EncodingConverttoObjCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 0},
{"dirs", EncodingDirsObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1},
{"names", EncodingNamesObjCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0},
{"profiles", EncodingProfilesObjCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0},
{"system", EncodingSystemObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1},
{"user", EncodingUserObjCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0},
{NULL, NULL, NULL, NULL, NULL, 0}
};
const EnsembleImplMap tclFileImplMap[] = {
{"atime", FileAttrAccessTimeCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 1},
{"attributes", TclFileAttrsCmd, NULL, NULL, NULL, 1},
{"channels", TclChannelNamesCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
{"copy", TclFileCopyCmd, NULL, NULL, NULL, 1},
{"delete", TclFileDeleteCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 1},
{"dirname", PathDirNameCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
{"executable", FileAttrIsExecutableCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
{"exists", FileAttrIsExistingCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
{"extension", PathExtensionCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
{"home", TclFileHomeCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1},
{"isdirectory", FileAttrIsDirectoryCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
{"isfile", FileAttrIsFileCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
{"join", PathJoinCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0},
{"link", TclFileLinkCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 1},
{"lstat", FileAttrLinkStatCmd, TclCompileBasic2ArgCmd, NULL, NULL, 1},
{"mtime", FileAttrModifyTimeCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 1},
{"mkdir", TclFileMakeDirsCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 1},
{"nativename", PathNativeNameCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
{"normalize", PathNormalizeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
{"owned", FileAttrIsOwnedCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
{"pathtype", PathTypeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"readable", FileAttrIsReadableCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
{"readlink", TclFileReadLinkCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
{"rename", TclFileRenameCmd, NULL, NULL, NULL, 1},
{"rootname", PathRootNameCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
{"separator", FilesystemSeparatorCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
{"size", FileAttrSizeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
{"split", PathSplitCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"stat", FileAttrStatCmd, TclCompileBasic2ArgCmd, NULL, NULL, 1},
{"system", PathFilesystemCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
{"tail", PathTailCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
{"tempdir", TclFileTempDirCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1},
{"tempfile", TclFileTemporaryCmd, TclCompileBasic0To2ArgCmd, NULL, NULL, 1},
{"tildeexpand", TclFileTildeExpandCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
{"type", FileAttrTypeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
{"volumes", FilesystemVolumesCmd, TclCompileBasic0ArgCmd, NULL, NULL, 1},
{"writable", FileAttrIsWritableCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
{NULL, NULL, NULL, NULL, NULL, 0}
};
/*
*----------------------------------------------------------------------
*
* Tcl_BreakObjCmd --
*
* This procedure is invoked to process the "break" Tcl command. See the
|
| ︙ | ︙ | |||
363 364 365 366 367 368 369 |
{
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return TCL_ERROR;
}
return TCL_CONTINUE;
}
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 415 416 417 418 419 420 421 422 423 424 425 426 427 428 |
{
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return TCL_ERROR;
}
return TCL_CONTINUE;
}
/*
*------------------------------------------------------------------------
*
* EncodingConvertParseOptions --
*
* Common routine for parsing arguments passed to encoding convertfrom
|
| ︙ | ︙ | |||
1112 1113 1114 1115 1116 1117 1118 |
if (result == TCL_OK) {
Tcl_SetObjResult(interp, resultPtr);
}
Tcl_DecrRefCount(resultPtr);
return result;
}
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 |
if (result == TCL_OK) {
Tcl_SetObjResult(interp, resultPtr);
}
Tcl_DecrRefCount(resultPtr);
return result;
}
/*
*----------------------------------------------------------------------
*
* FileAttrAccessTimeCmd --
*
* This function is invoked to process the "file atime" Tcl command. See
|
| ︙ | ︙ |
Changes to generic/tclCmdIL.c.
| ︙ | ︙ | |||
145 146 147 148 149 150 151 | SortInfo *infoPtr); /* * Array of values describing how to implement each standard subcommand of the * "info" command. */ | | | 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 |
SortInfo *infoPtr);
/*
* Array of values describing how to implement each standard subcommand of the
* "info" command.
*/
const EnsembleImplMap tclInfoImplMap[] = {
{"args", InfoArgsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"body", InfoBodyCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"cmdcount", InfoCmdCountCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0},
{"cmdtype", InfoCmdTypeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
{"commands", InfoCommandsCmd, TclCompileInfoCommandsCmd, NULL, NULL, 0},
{"complete", InfoCompleteCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"constant", TclInfoConstantCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
|
| ︙ | ︙ | |||
416 417 418 419 420 421 422 |
* Set the interpreter's object result to refer to the variable's new
* value object.
*/
Tcl_SetObjResult(interp, newValuePtr);
return TCL_OK;
}
| < < < < < < < < < < < < < < < < < < < < < < < < | 416 417 418 419 420 421 422 423 424 425 426 427 428 429 |
* Set the interpreter's object result to refer to the variable's new
* value object.
*/
Tcl_SetObjResult(interp, newValuePtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* InfoArgsCmd --
*
* Called to implement the "info args" command that returns the argument
|
| ︙ | ︙ |
Changes to generic/tclCmdMZ.c.
| ︙ | ︙ | |||
29 30 31 32 33 34 35 36 37 38 39 40 41 42 | static Tcl_NRPostProc TryPostFinal; static Tcl_NRPostProc TryPostHandler; static int UniCharIsAscii(int character); static int UniCharIsHexDigit(int character); static int StringCmpOpts(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int *nocase, Tcl_Size *reqlength); /* * Default set of characters to trim in [string trim] and friends. This is a * UTF-8 literal string containing all Unicode space characters [TIP #413] */ const char tclDefaultTrimSet[] = | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 70 71 72 73 74 75 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 104 105 106 107 |
static Tcl_NRPostProc TryPostFinal;
static Tcl_NRPostProc TryPostHandler;
static int UniCharIsAscii(int character);
static int UniCharIsHexDigit(int character);
static int StringCmpOpts(Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[], int *nocase,
Tcl_Size *reqlength);
static Tcl_ObjCmdProc StringCatCmd;
static Tcl_ObjCmdProc StringCmpCmd;
static Tcl_ObjCmdProc StringEqualCmd;
static Tcl_ObjCmdProc StringFirstCmd;
static Tcl_ObjCmdProc StringIndexCmd;
static Tcl_ObjCmdProc StringInsertCmd;
static Tcl_ObjCmdProc StringIsCmd;
static Tcl_ObjCmdProc StringLastCmd;
static Tcl_ObjCmdProc StringLenCmd;
static Tcl_ObjCmdProc StringMapCmd;
static Tcl_ObjCmdProc StringMatchCmd;
static Tcl_ObjCmdProc StringRangeCmd;
static Tcl_ObjCmdProc StringReptCmd;
static Tcl_ObjCmdProc StringRplcCmd;
static Tcl_ObjCmdProc StringRevCmd;
static Tcl_ObjCmdProc StringLowerCmd;
static Tcl_ObjCmdProc StringUpperCmd;
static Tcl_ObjCmdProc StringTitleCmd;
static Tcl_ObjCmdProc StringTrimCmd;
static Tcl_ObjCmdProc StringTrimLCmd;
static Tcl_ObjCmdProc StringTrimRCmd;
static Tcl_ObjCmdProc StringEndCmd;
static Tcl_ObjCmdProc StringStartCmd;
static Tcl_ObjCmdProc TclUnicodeNormalizeCmd;
/*
* Definition of the contents of the [string] ensemble.
*/
const EnsembleImplMap tclStringImplMap[] = {
{"cat", StringCatCmd, TclCompileStringCatCmd, NULL, NULL, 0},
{"compare", StringCmpCmd, TclCompileStringCmpCmd, NULL, NULL, 0},
{"equal", StringEqualCmd, TclCompileStringEqualCmd, NULL, NULL, 0},
{"first", StringFirstCmd, TclCompileStringFirstCmd, NULL, NULL, 0},
{"index", StringIndexCmd, TclCompileStringIndexCmd, NULL, NULL, 0},
{"insert", StringInsertCmd, TclCompileStringInsertCmd, NULL, NULL, 0},
{"is", StringIsCmd, TclCompileStringIsCmd, NULL, NULL, 0},
{"last", StringLastCmd, TclCompileStringLastCmd, NULL, NULL, 0},
{"length", StringLenCmd, TclCompileStringLenCmd, NULL, NULL, 0},
{"map", StringMapCmd, TclCompileStringMapCmd, NULL, NULL, 0},
{"match", StringMatchCmd, TclCompileStringMatchCmd, NULL, NULL, 0},
{"range", StringRangeCmd, TclCompileStringRangeCmd, NULL, NULL, 0},
{"repeat", StringReptCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
{"replace", StringRplcCmd, TclCompileStringReplaceCmd, NULL, NULL, 0},
{"reverse", StringRevCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"tolower", StringLowerCmd, TclCompileStringToLowerCmd, NULL, NULL, 0},
{"toupper", StringUpperCmd, TclCompileStringToUpperCmd, NULL, NULL, 0},
{"totitle", StringTitleCmd, TclCompileStringToTitleCmd, NULL, NULL, 0},
{"trim", StringTrimCmd, TclCompileStringTrimCmd, NULL, NULL, 0},
{"trimleft", StringTrimLCmd, TclCompileStringTrimLCmd, NULL, NULL, 0},
{"trimright", StringTrimRCmd, TclCompileStringTrimRCmd, NULL, NULL, 0},
{"wordend", StringEndCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
{"wordstart", StringStartCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
{NULL, NULL, NULL, NULL, NULL, 0}
};
/*
* Definition of the contents of the [unicode] ensemble.
*/
const EnsembleImplMap tclUnicodeImplMap[] = {
{"tonfc", TclUnicodeNormalizeCmd, NULL, NULL, (void *)TCL_NFC, 0},
{"tonfd", TclUnicodeNormalizeCmd, NULL, NULL, (void *)TCL_NFD, 0},
{"tonfkc", TclUnicodeNormalizeCmd, NULL, NULL, (void *)TCL_NFKC, 0},
{"tonfkd", TclUnicodeNormalizeCmd, NULL, NULL, (void *)TCL_NFKD, 0},
{NULL, NULL, NULL, NULL, NULL, 0}
};
/*
* Default set of characters to trim in [string trim] and friends. This is a
* UTF-8 literal string containing all Unicode space characters [TIP #413]
*/
const char tclDefaultTrimSet[] =
|
| ︙ | ︙ | |||
3262 3263 3264 3265 3266 3267 3268 |
Tcl_SetObjResult(interp, Tcl_NewStringObj(string1, length1-trim));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 |
Tcl_SetObjResult(interp, Tcl_NewStringObj(string1, length1-trim));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_SubstObjCmd --
*
* This procedure is invoked to process the "subst" Tcl command. See the
* user documentation for details on what it does. This command relies on
* Tcl_SubstObj() for its implementation.
*
* Results:
|
| ︙ | ︙ | |||
5475 5476 5477 5478 5479 5480 5481 |
&ds) != TCL_OK) {
return TCL_ERROR;
}
Tcl_DStringResult(interp, &ds);
return TCL_OK;
}
| < < < < < < < < < < < < < < < < < < < < < < < < < < < | 5483 5484 5485 5486 5487 5488 5489 5490 5491 5492 5493 5494 5495 5496 5497 |
&ds) != TCL_OK) {
return TCL_ERROR;
}
Tcl_DStringResult(interp, &ds);
return TCL_OK;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclCompCmds.c.
| ︙ | ︙ | |||
3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 |
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr = parsePtr->tokenPtr;
Tcl_Obj **objv, *formatObj, *tmpObj;
const char *bytes, *start;
Tcl_Size i, j, numWords = parsePtr->numWords;
/* TODO: Consider support for compiling expanded args. */
/*
* Don't handle any guaranteed-error cases.
*/
if (numWords < 2 || numWords > UINT_MAX) {
| > | 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 |
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr = parsePtr->tokenPtr;
Tcl_Obj **objv, *formatObj, *tmpObj;
const char *bytes, *start;
Tcl_Size i, j, numWords = parsePtr->numWords;
/* TODO: Consider support for runtime formats. */
/* TODO: Consider support for compiling expanded args. */
/*
* Don't handle any guaranteed-error cases.
*/
if (numWords < 2 || numWords > UINT_MAX) {
|
| ︙ | ︙ |
Changes to generic/tclDictObj.c.
| ︙ | ︙ | |||
61 62 63 64 65 66 67 | static Tcl_NRPostProc DictForLoopCallback; static Tcl_NRPostProc DictMapLoopCallback; /* * Table of dict subcommand names and implementations. */ | | | 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 |
static Tcl_NRPostProc DictForLoopCallback;
static Tcl_NRPostProc DictMapLoopCallback;
/*
* Table of dict subcommand names and implementations.
*/
const EnsembleImplMap tclDictImplMap[] = {
{"append", DictAppendCmd, TclCompileDictAppendCmd, NULL, NULL, 0 },
{"create", DictCreateCmd, TclCompileDictCreateCmd, NULL, NULL, 0 },
{"exists", DictExistsCmd, TclCompileDictExistsCmd, NULL, NULL, 0 },
{"filter", DictFilterCmd, NULL, NULL, NULL, 0 },
{"for", NULL, TclCompileDictForCmd, DictForNRCmd, NULL, 0 },
{"get", DictGetCmd, TclCompileDictGetCmd, NULL, NULL, 0 },
{"getdef", DictGetDefCmd, TclCompileDictGetWithDefaultCmd, NULL,NULL,0},
|
| ︙ | ︙ | |||
3962 3963 3964 3965 3966 3967 3968 |
TclDecrRefCount(dictPtr);
}
return TCL_ERROR;
}
return TCL_OK;
}
| < < < < < < < < < < < < < < < < < < < < < < < < < | 3962 3963 3964 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 3975 |
TclDecrRefCount(dictPtr);
}
return TCL_ERROR;
}
return TCL_OK;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclIOCmd.c.
| ︙ | ︙ | |||
41 42 43 44 45 46 47 | */ #define ASSOC_KEY "tclTCPAcceptCallbacks" /* * Static functions for this file: */ | | | | > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 |
*/
#define ASSOC_KEY "tclTCPAcceptCallbacks"
/*
* Static functions for this file:
*/
static Tcl_ExitProc FinalizeIOCmdTSD;
static Tcl_TcpAcceptProc AcceptCallbackProc;
static Tcl_ObjCmdProc ChanIsBinaryCmd;
static Tcl_ObjCmdProc ChanPendingObjCmd;
static Tcl_ObjCmdProc ChanPipeObjCmd;
static Tcl_ObjCmdProc ChanTruncateObjCmd;
static void RegisterTcpServerInterpCleanup(
Tcl_Interp *interp,
AcceptCallback *acceptCallbackPtr);
static Tcl_InterpDeleteProc TcpAcceptCallbacksDeleteProc;
static void TcpServerCloseProc(void *callbackData);
static void UnregisterTcpServerInterpCleanupProc(
Tcl_Interp *interp,
AcceptCallback *acceptCallbackPtr);
/*
* The basic description of the parts of the [chan] ensemble.
* Also contains [chan configure], which is [fconfigure].
*/
const EnsembleImplMap tclChanImplMap[] = {
{"blocked", Tcl_FblockedObjCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"close", Tcl_CloseObjCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
{"copy", Tcl_FcopyObjCmd, NULL, NULL, NULL, 0},
{"create", TclChanCreateObjCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, /* TIP #219 */
{"eof", Tcl_EofObjCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"event", Tcl_FileEventObjCmd, TclCompileBasic2Or3ArgCmd, NULL, NULL, 0},
{"flush", Tcl_FlushObjCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"gets", Tcl_GetsObjCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
{"isbinary", ChanIsBinaryCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"names", TclChannelNamesCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
{"pending", ChanPendingObjCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, /* TIP #287 */
{"pipe", ChanPipeObjCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, /* TIP #304 */
{"pop", TclChanPopObjCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, /* TIP #230 */
{"postevent", TclChanPostEventObjCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, /* TIP #219 */
{"push", TclChanPushObjCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, /* TIP #230 */
{"puts", Tcl_PutsObjCmd, NULL, NULL, NULL, 0},
{"read", Tcl_ReadObjCmd, NULL, NULL, NULL, 0},
{"seek", Tcl_SeekObjCmd, TclCompileBasic2Or3ArgCmd, NULL, NULL, 0},
{"tell", Tcl_TellObjCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"truncate", ChanTruncateObjCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, /* TIP #208 */
{NULL, NULL, NULL, NULL, NULL, 0}
};
/*
*----------------------------------------------------------------------
*
* FinalizeIOCmdTSD --
*
* Release the storage associated with the per-thread cache.
|
| ︙ | ︙ | |||
2078 2079 2080 2081 2082 2083 2084 |
return Tcl_GetChannelNamesEx(interp,
((objc == 1) ? NULL : TclGetString(objv[1])));
}
/*
*----------------------------------------------------------------------
*
| | | | | | | | > | < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < | < | 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 |
return Tcl_GetChannelNamesEx(interp,
((objc == 1) ? NULL : TclGetString(objv[1])));
}
/*
*----------------------------------------------------------------------
*
* TclSetUpChanCmd --
*
* This function is invoked to set up the "chan" Tcl command. See the
* user documentation for details on what it does.
*
* Results:
* Tcl result code.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclSetUpChanCmd(
Tcl_Interp *interp,
Tcl_Command ensemble)
{
/*
* Most commands are plugged directly together, but some are done via
* alias-like rewriting; [chan configure] is this way for security reasons
* (want overwriting of [fconfigure] to control that nicely).
*/
Tcl_Obj *mapObj;
Tcl_GetEnsembleMappingDict(NULL, ensemble, &mapObj);
TclDictPutString(NULL, mapObj, "configure", "::fconfigure");
return Tcl_SetEnsembleMappingDict(interp, ensemble, mapObj);
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclIndexObj.c.
| ︙ | ︙ | |||
27 28 29 30 31 32 33 34 35 36 37 38 39 40 |
static void FreeIndex(Tcl_Obj *objPtr);
static Tcl_ObjCmdProc PrefixAllObjCmd;
static Tcl_ObjCmdProc PrefixLongestObjCmd;
static Tcl_ObjCmdProc PrefixMatchObjCmd;
static void PrintUsage(Tcl_Interp *interp,
const Tcl_ArgvInfo *argTable);
/*
* The structure below defines the index Tcl object type by means of functions
* that can be invoked by generic object code.
*/
const Tcl_ObjType tclIndexType = {
"index", /* name */
| > > > > > > > | 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 |
static void FreeIndex(Tcl_Obj *objPtr);
static Tcl_ObjCmdProc PrefixAllObjCmd;
static Tcl_ObjCmdProc PrefixLongestObjCmd;
static Tcl_ObjCmdProc PrefixMatchObjCmd;
static void PrintUsage(Tcl_Interp *interp,
const Tcl_ArgvInfo *argTable);
const EnsembleImplMap tclPrefixImplMap[] = {
{"all", PrefixAllObjCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
{"longest", PrefixLongestObjCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
{"match", PrefixMatchObjCmd, TclCompileBasicMin2ArgCmd, NULL, NULL, 0},
{NULL, NULL, NULL, NULL, NULL, 0}
};
/*
* The structure below defines the index Tcl object type by means of functions
* that can be invoked by generic object code.
*/
const Tcl_ObjType tclIndexType = {
"index", /* name */
|
| ︙ | ︙ | |||
454 455 456 457 458 459 460 |
Tcl_Free(TclFetchInternalRep(objPtr, &tclIndexType)->twoPtrValue.ptr1);
objPtr->typePtr = NULL;
}
/*
*----------------------------------------------------------------------
*
| | | | | | | < < < < < < < | | < | < | 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 |
Tcl_Free(TclFetchInternalRep(objPtr, &tclIndexType)->twoPtrValue.ptr1);
objPtr->typePtr = NULL;
}
/*
*----------------------------------------------------------------------
*
* TclSetUpPrefixCmd --
*
* This procedure sets up the "prefix" Tcl command. See the user
* documentation for details on what it does.
*
* Results:
* Tcl result code.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
TclSetUpPrefixCmd(
Tcl_Interp *interp, /* Current interpreter. */
Tcl_Command ensemble) /* The prefix ensemble. */
{
return Tcl_Export(interp, (Tcl_Namespace*)((Command *)ensemble)->nsPtr,
"prefix", 0);
}
/*----------------------------------------------------------------------
*
* PrefixMatchObjCmd --
*
* This function implements the 'prefix match' Tcl command. Refer to the
|
| ︙ | ︙ |
Changes to generic/tclInt.h.
| ︙ | ︙ | |||
1764 1765 1766 1767 1768 1769 1770 | /* * Structure used in implementation of those core ensembles which are * partially compiled. Used as an array of these, with a terminating field * whose 'name' is NULL. */ | | | 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 |
/*
* Structure used in implementation of those core ensembles which are
* partially compiled. Used as an array of these, with a terminating field
* whose 'name' is NULL.
*/
typedef struct EnsembleImplMap {
const char *name; /* The name of the subcommand. */
Tcl_ObjCmdProc *proc; /* The implementation of the subcommand. */
CompileProc *compileProc; /* The compiler for the subcommand. */
Tcl_ObjCmdProc *nreProc; /* NRE implementation of this command. */
void *clientData; /* Any clientData to give the command. */
int unsafe; /* Whether this command is to be hidden by
* default in a safe interpreter. */
|
| ︙ | ︙ | |||
3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 | */ MODULE_SCOPE const Tcl_HashKeyType tclArrayHashKeyType; MODULE_SCOPE const Tcl_HashKeyType tclOneWordHashKeyType; MODULE_SCOPE const Tcl_HashKeyType tclStringHashKeyType; MODULE_SCOPE const Tcl_HashKeyType tclObjHashKeyType; /* * The head of the list of free Tcl objects, and the total number of Tcl * objects ever allocated and freed. */ MODULE_SCOPE Tcl_Obj * tclFreeObjList; | > > > > > > > > > > > > > > > > > > > > > > | 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 |
*/
MODULE_SCOPE const Tcl_HashKeyType tclArrayHashKeyType;
MODULE_SCOPE const Tcl_HashKeyType tclOneWordHashKeyType;
MODULE_SCOPE const Tcl_HashKeyType tclStringHashKeyType;
MODULE_SCOPE const Tcl_HashKeyType tclObjHashKeyType;
/*
* Tables ("implementation maps") used to declare ensembles.
*/
MODULE_SCOPE const EnsembleImplMap tclArrayImplMap[];
MODULE_SCOPE const EnsembleImplMap tclBinaryImplMap[];
MODULE_SCOPE const EnsembleImplMap tclBinaryEncodeImplMap[];
MODULE_SCOPE const EnsembleImplMap tclBinaryDecodeImplMap[];
MODULE_SCOPE const EnsembleImplMap tclChanImplMap[];
MODULE_SCOPE const EnsembleImplMap tclClockImplMap[];
MODULE_SCOPE const EnsembleImplMap tclDictImplMap[];
MODULE_SCOPE const EnsembleImplMap tclEncodingImplMap[];
MODULE_SCOPE const EnsembleImplMap tclFileImplMap[];
MODULE_SCOPE const EnsembleImplMap tclInfoImplMap[];
MODULE_SCOPE const EnsembleImplMap tclNamespaceImplMap[];
MODULE_SCOPE const EnsembleImplMap tclPrefixImplMap[];
MODULE_SCOPE const EnsembleImplMap tclProcessImplMap[];
MODULE_SCOPE const EnsembleImplMap tclStringImplMap[];
MODULE_SCOPE const EnsembleImplMap tclUnicodeImplMap[];
MODULE_SCOPE const EnsembleImplMap tclZipfsImplMap[];
MODULE_SCOPE const EnsembleImplMap tclZlibImplMap[];
/*
* The head of the list of free Tcl objects, and the total number of Tcl
* objects ever allocated and freed.
*/
MODULE_SCOPE Tcl_Obj * tclFreeObjList;
|
| ︙ | ︙ | |||
3728 3729 3730 3731 3732 3733 3734 | * Command procedures in the generic core: *---------------------------------------------------------------- */ MODULE_SCOPE Tcl_ObjCmdProc Tcl_AfterObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_AppendObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_ApplyObjCmd; | < < | > < | 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 | * Command procedures in the generic core: *---------------------------------------------------------------- */ MODULE_SCOPE Tcl_ObjCmdProc Tcl_AfterObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_AppendObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_ApplyObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_BreakObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_CatchObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_CdObjCmd; MODULE_SCOPE int TclSetUpChanCmd(Tcl_Interp *interp, Tcl_Command chanEnsemble); MODULE_SCOPE Tcl_ObjCmdProc TclChanCreateObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclChanPostEventObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclChanPopObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclChanPushObjCmd; MODULE_SCOPE void TclClockInit(Tcl_Interp *interp); MODULE_SCOPE Tcl_ObjCmdProc TclClockOldscanObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_CloseObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_ConcatObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_ConstObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_ContinueObjCmd; MODULE_SCOPE Tcl_TimerToken TclCreateAbsoluteTimerHandler( Tcl_Time *timePtr, Tcl_TimerProc *proc, void *clientData); MODULE_SCOPE Tcl_ObjCmdProc TclDefaultBgErrorHandlerObjCmd; MODULE_SCOPE int TclDictWithFinish(Tcl_Interp *interp, Var *varPtr, Var *arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Size index, Tcl_Size pathc, Tcl_Obj *const pathv[], Tcl_Obj *keysPtr); MODULE_SCOPE Tcl_Obj * TclDictWithInit(Tcl_Interp *interp, Tcl_Obj *dictPtr, Tcl_Size pathc, Tcl_Obj *const pathv[]); MODULE_SCOPE Tcl_ObjCmdProc Tcl_DisassembleObjCmd; |
| ︙ | ︙ | |||
3771 3772 3773 3774 3775 3776 3777 | MODULE_SCOPE Tcl_ObjCmdProc Tcl_EvalObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_ExecObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_ExitObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_ExprObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_FblockedObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_FconfigureObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_FcopyObjCmd; | < < | 3791 3792 3793 3794 3795 3796 3797 3798 3799 3800 3801 3802 3803 3804 3805 3806 3807 3808 3809 3810 3811 3812 3813 3814 | MODULE_SCOPE Tcl_ObjCmdProc Tcl_EvalObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_ExecObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_ExitObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_ExprObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_FblockedObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_FconfigureObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_FcopyObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_FileEventObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_FlushObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_ForObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_ForeachObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_FormatObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_GetsObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_GlobalObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_GlobObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_IfObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_IncrObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_InterpObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_JoinObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_LappendObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_LassignObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_LeditObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_LindexObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_LinsertObjCmd; |
| ︙ | ︙ | |||
3804 3805 3806 3807 3808 3809 3810 | MODULE_SCOPE Tcl_ObjCmdProc Tcl_LrepeatObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_LreplaceObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_LreverseObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_LsearchObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_LseqObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_LsetObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_LsortObjCmd; | < | > < < | 3822 3823 3824 3825 3826 3827 3828 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 3853 3854 3855 3856 | MODULE_SCOPE Tcl_ObjCmdProc Tcl_LrepeatObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_LreplaceObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_LreverseObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_LsearchObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_LseqObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_LsetObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_LsortObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNamespaceEnsembleCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_OpenObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_PackageObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_PidObjCmd; MODULE_SCOPE int TclSetUpPrefixCmd(Tcl_Interp *interp, Tcl_Command prefixEnsemble); MODULE_SCOPE Tcl_ObjCmdProc Tcl_PutsObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_PwdObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_ReadObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_RegexpObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_RegsubObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_RenameObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_RepresentationCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_ReturnObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclSafeCatchCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_ScanObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_SeekObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_SetObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_SplitObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_SocketObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_SourceObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_SubstObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_SwitchObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_TellObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_ThrowObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_TimeObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_TimeRateObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_TraceObjCmd; |
| ︙ | ︙ | |||
4136 4137 4138 4139 4140 4141 4142 |
TCL_PROCESS_EXITED = 1, /* Process has exited. */
TCL_PROCESS_SIGNALED = 2, /* Child killed because of a signal. */
TCL_PROCESS_STOPPED = 3, /* Child suspended because of a signal. */
TCL_PROCESS_UNKNOWN_STATUS = 4
/* Child wait status didn't make sense. */
} TclProcessWaitStatus;
| | > | 4152 4153 4154 4155 4156 4157 4158 4159 4160 4161 4162 4163 4164 4165 4166 4167 |
TCL_PROCESS_EXITED = 1, /* Process has exited. */
TCL_PROCESS_SIGNALED = 2, /* Child killed because of a signal. */
TCL_PROCESS_STOPPED = 3, /* Child suspended because of a signal. */
TCL_PROCESS_UNKNOWN_STATUS = 4
/* Child wait status didn't make sense. */
} TclProcessWaitStatus;
MODULE_SCOPE int TclSetUpProcessCmd(Tcl_Interp *interp,
Tcl_Command processEnsemble);
MODULE_SCOPE void TclProcessCreated(Tcl_Pid pid);
MODULE_SCOPE TclProcessWaitStatus TclProcessWait(Tcl_Pid pid, int options,
int *codePtr, Tcl_Obj **msgObjPtr,
Tcl_Obj **errorObjPtr);
MODULE_SCOPE int TclClose(Tcl_Interp *, Tcl_Channel chan);
/*
|
| ︙ | ︙ |
Changes to generic/tclInterp.c.
| ︙ | ︙ | |||
442 443 444 445 446 447 448 |
" }\n"
" set dirs {}\n"
" set errors {}\n"
" foreach script $scripts {\n"
" if {[set tcl_library [eval $script]] eq \"\"} continue\n"
" set tclfile [file join $tcl_library init.tcl]\n"
" if {[file exists $tclfile]} {\n"
| > | > | 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 |
" }\n"
" set dirs {}\n"
" set errors {}\n"
" foreach script $scripts {\n"
" if {[set tcl_library [eval $script]] eq \"\"} continue\n"
" set tclfile [file join $tcl_library init.tcl]\n"
" if {[file exists $tclfile]} {\n"
" try {\n"
" uplevel #0 [list source $tclfile]\n"
" } on error {msg opts} {\n"
" append errors \"$tclfile: $msg\n\"\n"
" append errors \"[dict get $opts -errorinfo]\n\"\n"
" continue\n"
" }\n"
" unset -nocomplain tclDefaultLibrary\n"
" return\n"
" }\n"
|
| ︙ | ︙ |
Changes to generic/tclNamesp.c.
| ︙ | ︙ | |||
152 153 154 155 156 157 158 |
} while (false)
/*
* Array of values describing how to implement each standard subcommand of the
* "namespace" command.
*/
| | | | | 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 |
} while (false)
/*
* Array of values describing how to implement each standard subcommand of the
* "namespace" command.
*/
const EnsembleImplMap tclNamespaceImplMap[] = {
{"children", NamespaceChildrenCmd, TclCompileBasic0To2ArgCmd, NULL, NULL, 0},
{"code", NamespaceCodeCmd, TclCompileNamespaceCodeCmd, NULL, NULL, 0},
{"current", NamespaceCurrentCmd, TclCompileNamespaceCurrentCmd, NULL, NULL, 0},
{"delete", NamespaceDeleteCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 0},
{"ensemble", TclNamespaceEnsembleCmd, NULL, NULL, NULL, 0},
{"eval", NamespaceEvalCmd, NULL, NRNamespaceEvalCmd, NULL, 0},
{"exists", NamespaceExistsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, // TODO: compile?
{"export", NamespaceExportCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 0},
{"forget", NamespaceForgetCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 0},
{"import", NamespaceImportCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 0},
{"inscope", NamespaceInscopeCmd, NULL, NRNamespaceInscopeCmd, NULL, 0},
{"origin", NamespaceOriginCmd, TclCompileNamespaceOriginCmd, NULL, NULL, 0},
{"parent", NamespaceParentCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, // TODO: compile?
{"path", NamespacePathCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
{"qualifiers", NamespaceQualifiersCmd, TclCompileNamespaceQualifiersCmd, NULL, NULL, 0},
{"tail", NamespaceTailCmd, TclCompileNamespaceTailCmd, NULL, NULL, 0},
{"unknown", NamespaceUnknownCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
{"upvar", NamespaceUpvarCmd, TclCompileNamespaceUpvarCmd, NULL, NULL, 0},
{"which", NamespaceWhichCmd, TclCompileNamespaceWhichCmd, NULL, NULL, 0},
{NULL, NULL, NULL, NULL, NULL, 0}
|
| ︙ | ︙ | |||
2537 2538 2539 2540 2541 2542 2543 |
Tcl_Namespace *
TclEnsureNamespace(
Tcl_Interp *interp,
Tcl_Namespace *namespacePtr)
{
Namespace *nsPtr = (Namespace *) namespacePtr;
if (!(nsPtr->flags & NS_DYING)) {
| | | 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 |
Tcl_Namespace *
TclEnsureNamespace(
Tcl_Interp *interp,
Tcl_Namespace *namespacePtr)
{
Namespace *nsPtr = (Namespace *) namespacePtr;
if (!(nsPtr->flags & NS_DYING)) {
return namespacePtr;
}
return Tcl_CreateNamespace(interp, nsPtr->fullName, NULL, NULL);
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
3075 3076 3077 3078 3079 3080 3081 |
resNamePtr->refNsPtr = NULL;
resNamePtr->refCount = 0;
nsPtr->refCount++;
NsNameSetInternalRep(objPtr, resNamePtr);
}
return objPtr;
}
| < < < < < < < < < < < < < < < < < < < < < < < < | 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 |
resNamePtr->refNsPtr = NULL;
resNamePtr->refCount = 0;
nsPtr->refCount++;
NsNameSetInternalRep(objPtr, resNamePtr);
}
return objPtr;
}
/*
*----------------------------------------------------------------------
*
* NamespaceChildrenCmd --
*
* Invoked to implement the "namespace children" command that returns a
|
| ︙ | ︙ |
Changes to generic/tclOOInfo.c.
| ︙ | ︙ | |||
43 44 45 46 47 48 49 | static Tcl_ObjCmdProc InfoClassSubsCmd; static Tcl_ObjCmdProc InfoClassSupersCmd; static Tcl_ObjCmdProc InfoClassVariablesCmd; /* * List of commands that are used to implement the [info object] subcommands. */ | < | < | | 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 71 72 73 74 75 76 77 78 |
static Tcl_ObjCmdProc InfoClassSubsCmd;
static Tcl_ObjCmdProc InfoClassSupersCmd;
static Tcl_ObjCmdProc InfoClassVariablesCmd;
/*
* List of commands that are used to implement the [info object] subcommands.
*/
static const EnsembleImplMap infoObjectImplMap[] = {
{"call", InfoObjectCallCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
{"class", InfoObjectClassCmd, TclCompileInfoObjectClassCmd, NULL, NULL, 0},
{"creationid", InfoObjectIdCmd, TclCompileInfoObjectCreationIdCmd, NULL, NULL, 0},
{"definition", InfoObjectDefnCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
{"filters", InfoObjectFiltersCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"forward", InfoObjectForwardCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
{"isa", InfoObjectIsACmd, TclCompileInfoObjectIsACmd, NULL, NULL, 0},
{"methods", InfoObjectMethodsCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0},
{"methodtype", InfoObjectMethodTypeCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
{"mixins", InfoObjectMixinsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"namespace", InfoObjectNsCmd, TclCompileInfoObjectNamespaceCmd, NULL, NULL, 0},
{"properties", TclOOInfoObjectPropCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0},
{"variables", InfoObjectVariablesCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
{"vars", InfoObjectVarsCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
{NULL, NULL, NULL, NULL, NULL, 0}
};
/*
* List of commands that are used to implement the [info class] subcommands.
*/
static const EnsembleImplMap infoClassImplMap[] = {
{"call", InfoClassCallCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
{"constructor", InfoClassConstrCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"definition", InfoClassDefnCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
{"definitionnamespace", InfoClassDefnNsCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
{"destructor", InfoClassDestrCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"filters", InfoClassFiltersCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"forward", InfoClassForwardCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
|
| ︙ | ︙ | |||
141 142 143 144 145 146 147 |
Tcl_Command infoCmd;
Tcl_Obj *mapDict;
/*
* Build the ensembles used to implement [info object] and [info class].
*/
| | | > > > | 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 |
Tcl_Command infoCmd;
Tcl_Obj *mapDict;
/*
* Build the ensembles used to implement [info object] and [info class].
*/
TclMakeEnsemble(interp, "::oo::InfoObject", infoObjectImplMap);
TclMakeEnsemble(interp, "::oo::InfoClass", infoClassImplMap);
/*
* Install into the [info] ensemble.
* We keep the subcommands with their existing names instead of the
* auto-generated ones supported by the ensemble guts because we're
* somewhat documented to work this way.
*/
infoCmd = Tcl_FindCommand(interp, "info", NULL, TCL_GLOBAL_ONLY);
if (infoCmd) {
Tcl_GetEnsembleMappingDict(NULL, infoCmd, &mapDict);
TclDictPutString(NULL, mapDict, "object", "::oo::InfoObject");
TclDictPutString(NULL, mapDict, "class", "::oo::InfoClass");
|
| ︙ | ︙ |
Changes to generic/tclProcess.c.
| ︙ | ︙ | |||
48 49 50 51 52 53 54 | Tcl_Size resolvedPid); static void FreeProcessInfo(ProcessInfo *info); static int RefreshProcessInfo(ProcessInfo *info, int options); static TclProcessWaitStatus WaitProcessStatus(Tcl_Pid pid, Tcl_Size resolvedPid, int options, int *codePtr, Tcl_Obj **msgPtr, Tcl_Obj **errorObjPtr); static Tcl_Obj * BuildProcessStatusObj(ProcessInfo *info); | | > | | > > > > > | > > | | 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 |
Tcl_Size resolvedPid);
static void FreeProcessInfo(ProcessInfo *info);
static int RefreshProcessInfo(ProcessInfo *info, int options);
static TclProcessWaitStatus WaitProcessStatus(Tcl_Pid pid, Tcl_Size resolvedPid,
int options, int *codePtr, Tcl_Obj **msgPtr,
Tcl_Obj **errorObjPtr);
static Tcl_Obj * BuildProcessStatusObj(ProcessInfo *info);
static Tcl_ObjCmdProc ProcessListObjCmd;
static Tcl_ObjCmdProc ProcessStatusObjCmd;
static Tcl_ObjCmdProc ProcessPurgeObjCmd;
static Tcl_ObjCmdProc ProcessAutopurgeObjCmd;
const EnsembleImplMap tclProcessImplMap[] = {
{"list", ProcessListObjCmd, TclCompileBasic0ArgCmd, NULL, NULL, 1},
{"status", ProcessStatusObjCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 1},
{"purge", ProcessPurgeObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1},
{"autopurge", ProcessAutopurgeObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1},
{NULL, NULL, NULL, NULL, NULL, 0}
};
/*
*----------------------------------------------------------------------
*
* InitProcessInfo --
*
* Initializes the ProcessInfo structure.
*
|
| ︙ | ︙ | |||
747 748 749 750 751 752 753 |
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(autopurge));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
| | | | | | | < < < < < < < < | | < | < | 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 |
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(autopurge));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclSetUpProcessCmd --
*
* This procedure sets up the "tcl::process" Tcl command. See the user
* documentation for details on what it does.
*
* Results:
* Tcl result code.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
TclSetUpProcessCmd(
Tcl_Interp *interp, /* Current interpreter. */
Tcl_Command ensemble) /* The ensemble to set up. */
{
if (infoTablesInitialized == 0) {
Tcl_MutexLock(&infoTablesMutex);
if (infoTablesInitialized == 0) {
Tcl_InitHashTable(&infoTablePerPid, TCL_ONE_WORD_KEYS);
Tcl_InitHashTable(&infoTablePerResolvedPid, TCL_ONE_WORD_KEYS);
infoTablesInitialized = 1;
}
Tcl_MutexUnlock(&infoTablesMutex);
}
return Tcl_Export(interp, (Tcl_Namespace*)((Command *)ensemble)->nsPtr,
"process", 0);
}
/*
*----------------------------------------------------------------------
*
* TclProcessCreated --
*
|
| ︙ | ︙ |
Changes to generic/tclVar.c.
| ︙ | ︙ | |||
189 190 191 192 193 194 195 196 197 198 199 200 | /* * Forward references to functions defined later in this file: */ static void AppendLocals(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *patternPtr, int includeLinks, int justConstants); static void ArrayPopulateSearch(Tcl_Interp *interp, Tcl_Obj *arrayNameObj, Var *varPtr, ArraySearch *searchPtr); static void ArrayDoneSearch(Interp *iPtr, Var *varPtr, ArraySearch *searchPtr); | > > > > > > | > > > > > > | 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 | /* * Forward references to functions defined later in this file: */ static void AppendLocals(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *patternPtr, int includeLinks, int justConstants); static Tcl_ObjCmdProc ArrayAnyMoreCmd; static Tcl_ObjCmdProc ArrayDoneSearchCmd; static Tcl_ObjCmdProc ArrayNextElementCmd; static Tcl_ObjCmdProc ArrayStartSearchCmd; static void ArrayPopulateSearch(Tcl_Interp *interp, Tcl_Obj *arrayNameObj, Var *varPtr, ArraySearch *searchPtr); static void ArrayDoneSearch(Interp *iPtr, Var *varPtr, ArraySearch *searchPtr); static Tcl_ObjCmdProc ArrayExistsCmd; static Tcl_ObjCmdProc ArrayForObjCmd; static Tcl_NRPostProc ArrayForLoopCallback; static Tcl_ObjCmdProc ArrayForNRCmd; static Tcl_ObjCmdProc ArrayGetCmd; static Tcl_ObjCmdProc ArrayNamesCmd; static Tcl_ObjCmdProc ArraySetCmd; static Tcl_ObjCmdProc ArraySizeCmd; static Tcl_ObjCmdProc ArrayStatsCmd; static Tcl_ObjCmdProc ArrayUnsetCmd; static void DeleteSearches(Interp *iPtr, Var *arrayVarPtr); static void DeleteArray(Interp *iPtr, Tcl_Obj *arrayNamePtr, Var *varPtr, int flags, Tcl_Size index); static int LocateArray(Tcl_Interp *interp, Tcl_Obj *name, Var **varPtrPtr, int *isArrayPtr); static int NotArrayError(Tcl_Interp *interp, Tcl_Obj *name); static Tcl_Var ObjFindNamespaceVar(Tcl_Interp *interp, |
| ︙ | ︙ | |||
237 238 239 240 241 242 243 244 245 246 247 248 249 250 | const char **errMsgPtr, Tcl_Size *indexPtr); static Tcl_DupInternalRepProc DupLocalVarName; static Tcl_FreeInternalRepProc FreeLocalVarName; static Tcl_FreeInternalRepProc FreeParsedVarName; static Tcl_DupInternalRepProc DupParsedVarName; /* * Types of Tcl_Objs used to cache variable lookups. * * localVarName - INTERNALREP DEFINITION: * twoPtrValue.ptr1: pointer to name obj in varFramePtr->localCache * or NULL if it is this same obj | > > > > > > > > > > > > > > > > > | 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 |
const char **errMsgPtr, Tcl_Size *indexPtr);
static Tcl_DupInternalRepProc DupLocalVarName;
static Tcl_FreeInternalRepProc FreeLocalVarName;
static Tcl_FreeInternalRepProc FreeParsedVarName;
static Tcl_DupInternalRepProc DupParsedVarName;
const EnsembleImplMap tclArrayImplMap[] = {
{"anymore", ArrayAnyMoreCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
{"default", ArrayDefaultCmd, TclCompileBasic2Or3ArgCmd, NULL, NULL, 0},
{"donesearch", ArrayDoneSearchCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
{"exists", ArrayExistsCmd, TclCompileArrayExistsCmd, NULL, NULL, 0},
{"for", ArrayForObjCmd, TclCompileBasic3ArgCmd, ArrayForNRCmd, NULL, 0}, // TODO: compile?
{"get", ArrayGetCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
{"names", ArrayNamesCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 0},
{"nextelement", ArrayNextElementCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
{"set", ArraySetCmd, TclCompileArraySetCmd, NULL, NULL, 0},
{"size", ArraySizeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"startsearch", ArrayStartSearchCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"statistics", ArrayStatsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"unset", ArrayUnsetCmd, TclCompileArrayUnsetCmd, NULL, NULL, 0},
{NULL, NULL, NULL, NULL, NULL, 0}
};
/*
* Types of Tcl_Objs used to cache variable lookups.
*
* localVarName - INTERNALREP DEFINITION:
* twoPtrValue.ptr1: pointer to name obj in varFramePtr->localCache
* or NULL if it is this same obj
|
| ︙ | ︙ | |||
4438 4439 4440 4441 4442 4443 4444 |
CleanupVar(protectedVarPtr, varPtr);
}
return TCL_ERROR;
}
}
return TCL_OK;
}
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 4467 4468 4469 4470 4471 4472 4473 4474 4475 4476 4477 4478 4479 4480 |
CleanupVar(protectedVarPtr, varPtr);
}
return TCL_ERROR;
}
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ObjMakeUpvar --
*
* This function does all of the work of the "global" and "upvar"
|
| ︙ | ︙ |
Changes to generic/tclZipfs.c.
| ︙ | ︙ | |||
474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 |
int mask);
static int ZipChannelWrite(void *instanceData,
const char *buf, int toWrite, int *errloc);
static int TclZipfsInitEncodingDirs(void);
static int TclZipfsMountExe(void);
static int TclZipfsMountShlib(void);
/*
* Define the ZIP filesystem dispatch table.
*/
static const Tcl_Filesystem zipfsFilesystem = {
"zipfs",
sizeof(Tcl_Filesystem),
TCL_FILESYSTEM_VERSION_2,
ZipFSPathInFilesystemProc,
| > > > > > > > > > > > > > > | | | | | | | | | | | | | | | | | 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 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 |
int mask);
static int ZipChannelWrite(void *instanceData,
const char *buf, int toWrite, int *errloc);
static int TclZipfsInitEncodingDirs(void);
static int TclZipfsMountExe(void);
static int TclZipfsMountShlib(void);
static Tcl_ObjCmdProc ZipFSMkImgObjCmd;
static Tcl_ObjCmdProc ZipFSMkZipObjCmd;
static Tcl_ObjCmdProc ZipFSLMkImgObjCmd;
static Tcl_ObjCmdProc ZipFSLMkZipObjCmd;
static Tcl_ObjCmdProc ZipFSMountObjCmd;
static Tcl_ObjCmdProc ZipFSMountBufferObjCmd;
static Tcl_ObjCmdProc ZipFSUnmountObjCmd;
static Tcl_ObjCmdProc ZipFSMkKeyObjCmd;
static Tcl_ObjCmdProc ZipFSExistsObjCmd;
static Tcl_ObjCmdProc ZipFSInfoObjCmd;
static Tcl_ObjCmdProc ZipFSListObjCmd;
static Tcl_ObjCmdProc ZipFSCanonicalObjCmd;
static Tcl_ObjCmdProc ZipFSRootObjCmd;
/*
* Define the ZIP filesystem dispatch table.
*/
static const Tcl_Filesystem zipfsFilesystem = {
"zipfs",
sizeof(Tcl_Filesystem),
TCL_FILESYSTEM_VERSION_2,
ZipFSPathInFilesystemProc,
NULL, /* dupInternalRepProc */
NULL, /* freeInternalRepProc */
NULL, /* internalToNormalizedProc */
NULL, /* createInternalRepProc */
NULL, /* normalizePathProc */
ZipFSFilesystemPathTypeProc,
ZipFSFilesystemSeparatorProc,
ZipFSStatProc,
ZipFSAccessProc,
ZipFSOpenFileChannelProc,
ZipFSMatchInDirectoryProc,
NULL, /* utimeProc */
NULL, /* linkProc */
ZipFSListVolumesProc,
ZipFSFileAttrStringsProc,
ZipFSFileAttrsGetProc,
ZipFSFileAttrsSetProc,
NULL, /* createDirectoryProc */
NULL, /* removeDirectoryProc */
NULL, /* deleteFileProc */
NULL, /* copyFileProc */
NULL, /* renameFileProc */
NULL, /* copyDirectoryProc */
NULL, /* lstatProc */
(Tcl_FSLoadFileProc *) (void *) ZipFSLoadFile,
NULL, /* getCwdProc */
NULL /* chdirProc */
};
/*
* The channel type/driver definition used for ZIP archive members.
*/
static const Tcl_ChannelType zipChannelType = {
"zip",
|
| ︙ | ︙ | |||
534 535 536 537 538 539 540 541 542 543 544 545 546 547 |
NULL, /* Set blocking mode for raw channel. */
NULL, /* Function to flush channel. */
NULL, /* Function to handle bubbled events. */
ZipChannelWideSeek,
NULL, /* Thread action function. */
NULL, /* Truncate function. */
};
/*
*------------------------------------------------------------------------
*
* TclIsZipfsPath --
*
* Checks if the passed path has a zipfs volume prefix.
| > > > > > > > > > > > > > > > > > > > > > | 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 |
NULL, /* Set blocking mode for raw channel. */
NULL, /* Function to flush channel. */
NULL, /* Function to handle bubbled events. */
ZipChannelWideSeek,
NULL, /* Thread action function. */
NULL, /* Truncate function. */
};
/*
* The description of the [zipfs] ensemble command.
*/
const EnsembleImplMap tclZipfsImplMap[] = {
{"mkimg", ZipFSMkImgObjCmd, NULL, NULL, NULL, 1},
{"mkzip", ZipFSMkZipObjCmd, NULL, NULL, NULL, 1},
{"lmkimg", ZipFSLMkImgObjCmd, NULL, NULL, NULL, 1},
{"lmkzip", ZipFSLMkZipObjCmd, NULL, NULL, NULL, 1},
{"mount", ZipFSMountObjCmd, NULL, NULL, NULL, 1},
{"mountdata", ZipFSMountBufferObjCmd, NULL, NULL, NULL, 1},
{"unmount", ZipFSUnmountObjCmd, NULL, NULL, NULL, 1},
{"mkkey", ZipFSMkKeyObjCmd, NULL, NULL, NULL, 1},
{"exists", ZipFSExistsObjCmd, NULL, NULL, NULL, 1},
{"find", NULL, NULL, NULL, NULL, 0},
{"info", ZipFSInfoObjCmd, NULL, NULL, NULL, 1},
{"list", ZipFSListObjCmd, NULL, NULL, NULL, 1},
{"canonical", ZipFSCanonicalObjCmd, NULL, NULL, NULL, 1},
{"root", ZipFSRootObjCmd, NULL, NULL, NULL, 1},
{NULL, NULL, NULL, NULL, NULL, 0}
};
/*
*------------------------------------------------------------------------
*
* TclIsZipfsPath --
*
* Checks if the passed path has a zipfs volume prefix.
|
| ︙ | ︙ | |||
4302 4303 4304 4305 4306 4307 4308 | * * Side effects: * May mount the archive at the ZIPFS_APP_MOUNT mount point. * *------------------------------------------------------------------------- */ static int | | | 4337 4338 4339 4340 4341 4342 4343 4344 4345 4346 4347 4348 4349 4350 4351 |
*
* Side effects:
* May mount the archive at the ZIPFS_APP_MOUNT mount point.
*
*-------------------------------------------------------------------------
*/
static int
TclZipfsMountExe(void)
{
WriteLock();
if (!ZipFS.initialized) {
ZipfsSetup();
}
int mounted = (ZipFSLookupZip(ZIPFS_APP_MOUNT) != NULL);
Unlock();
|
| ︙ | ︙ | |||
4351 4352 4353 4354 4355 4356 4357 | * * Side effects: * May mount the archive at the ZIPFS_ZIP_MOUNT mount point. * *------------------------------------------------------------------------- */ static int | | | 4386 4387 4388 4389 4390 4391 4392 4393 4394 4395 4396 4397 4398 4399 4400 |
*
* Side effects:
* May mount the archive at the ZIPFS_ZIP_MOUNT mount point.
*
*-------------------------------------------------------------------------
*/
static int
TclZipfsMountShlib(void)
{
#if defined(STATIC_BUILD)
/* Static builds have no shared library */
return 0;
#else
WriteLock();
if (!ZipFS.initialized) {
|
| ︙ | ︙ | |||
6399 6400 6401 6402 6403 6404 6405 |
*-------------------------------------------------------------------------
*/
int
TclZipfs_Init(
Tcl_Interp *interp) /* Current interpreter. */
{
| < < < < < < < < < < < < < < < < | > | | | | 6434 6435 6436 6437 6438 6439 6440 6441 6442 6443 6444 6445 6446 6447 6448 6449 6450 6451 6452 6453 6454 6455 6456 6457 6458 |
*-------------------------------------------------------------------------
*/
int
TclZipfs_Init(
Tcl_Interp *interp) /* Current interpreter. */
{
static const char findproc[] =
"namespace eval ::tcl::zipfs {}\n"
"proc ::tcl::zipfs::Find dir {\n"
" set result {}\n"
" try {\n"
" set normal [glob -directory $dir -nocomplain *]\n"
" set hidden [glob -directory $dir -types hidden -nocomplain *]\n"
" } on error {} {\n"
" return $result\n"
" }\n"
" foreach file [concat $normal $hidden] {\n"
" if {[file tail $file] in {. ..}} {\n"
" continue\n"
" }\n"
" lappend result $file {*}[Find $file]\n"
" }\n"
" return $result\n"
"}\n"
|
| ︙ | ︙ | |||
6447 6448 6449 6450 6451 6452 6453 |
WriteLock();
if (!ZipFS.initialized) {
ZipfsSetup();
}
Unlock();
if (interp) {
| < < < < < < < < < < < < | 6467 6468 6469 6470 6471 6472 6473 6474 6475 6476 6477 6478 6479 6480 6481 6482 6483 6484 6485 6486 6487 |
WriteLock();
if (!ZipFS.initialized) {
ZipfsSetup();
}
Unlock();
if (interp) {
Tcl_EvalEx(interp, findproc, TCL_INDEX_NONE, TCL_EVAL_GLOBAL);
if (!Tcl_IsSafe(interp)) {
Tcl_LinkVar(interp, "::tcl::zipfs::wrmax", (char *) &ZipFS.wrmax,
TCL_LINK_INT);
Tcl_LinkVar(interp, "::tcl::zipfs::fallbackEntryEncoding",
(char *) &ZipFS.fallbackEntryEncoding, TCL_LINK_STRING);
}
Tcl_CreateObjCommand(interp, "::tcl::zipfs::tcl_library_init",
ZipFSTclLibraryObjCmd, NULL, NULL);
}
return TCL_OK;
}
/*
|
| ︙ | ︙ |
Changes to generic/tclZlib.c.
| ︙ | ︙ | |||
228 229 230 231 232 233 234 |
NULL, /* Flush proc. */
ZlibTransformEventHandler,
NULL, /* Seek proc. */
NULL, /* Thread action proc. */
NULL /* Truncate proc. */
};
| | | 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 |
NULL, /* Flush proc. */
ZlibTransformEventHandler,
NULL, /* Seek proc. */
NULL, /* Thread action proc. */
NULL /* Truncate proc. */
};
const EnsembleImplMap tclZlibImplMap[] = {
{"adler32", ZlibAdler32Cmd, NULL, NULL, NULL, 0},
{"compress", ZlibCompressCmd, NULL, NULL, NULL, 0},
{"crc32", ZlibCRC32Cmd, NULL, NULL, NULL, 0},
{"decompress", ZlibDecompressCmd, NULL, NULL, NULL, 0},
{"deflate", ZlibDeflateCmd, NULL, NULL, NULL, 0},
{"gunzip", ZlibGunzipCmd, NULL, NULL, NULL, 0},
{"gzip", ZlibGzipCmd, NULL, NULL, NULL, 0},
|
| ︙ | ︙ | |||
4107 4108 4109 4110 4111 4112 4113 |
Tcl_SetChannelError(chanDataPtr->parent, errObj);
*errorCodePtr = EINVAL;
return -1;
}
/*
*----------------------------------------------------------------------
| > | > > < < < < < < | 4107 4108 4109 4110 4111 4112 4113 4114 4115 4116 4117 4118 4119 4120 4121 4122 4123 4124 4125 4126 4127 4128 4129 4130 4131 4132 4133 4134 4135 4136 4137 4138 4139 4140 4141 4142 |
Tcl_SetChannelError(chanDataPtr->parent, errObj);
*errorCodePtr = EINVAL;
return -1;
}
/*
*----------------------------------------------------------------------
*
* Finally, the TclZlibInit function. Used to install the zlib API apart
* from the ensemble command.
*
*----------------------------------------------------------------------
*/
int
TclZlibInit(
Tcl_Interp *interp)
{
Tcl_Config cfg[2];
/*
* This does two things. It creates a counter used in the creation of
* stream commands, and it creates the namespace that will contain those
* commands.
*/
Tcl_EvalEx(interp, "namespace eval ::tcl::zlib {variable cmdcounter 0}",
TCL_AUTO_LENGTH, 0);
/*
* Store the underlying configuration information.
*
* TODO: Describe whether we're using the system version of the library or
* a compatibility version built into Tcl?
*/
|
| ︙ | ︙ |
Changes to library/icu.tcl.
| ︙ | ︙ | |||
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 |
::tcl::unsupported::loadIcu
namespace eval ::tcl::unsupported::icu {
# Map Tcl encoding names to ICU and back. Note ICU has multiple aliases
# for the same encoding.
variable tclToIcu
variable icuToTcl
proc LogError {message} {
puts stderr $message
}
# Constructs the full mappings between Tcl and ICU names for encodings.
proc Init {} {
variable tclToIcu
variable icuToTcl
# There are some special cases where names do not line up
# at all. Map Tcl -> ICU
array set specialCases {
ebcdic ebcdic-cp-us
macCentEuro maccentraleurope
utf16 UTF16_PlatformEndian
utf-16be UnicodeBig
utf-16le UnicodeLittle
utf32 UTF32_PlatformEndian
}
# Ignore all errors. Do not want to hold up Tcl
# if ICU not available
try {
foreach tclName [encoding names] {
try {
set icuNames [aliases $tclName]
| > > > > > > > | | | > < < < | 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 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 |
::tcl::unsupported::loadIcu
namespace eval ::tcl::unsupported::icu {
# Map Tcl encoding names to ICU and back. Note ICU has multiple aliases
# for the same encoding.
variable tclToIcu
variable icuToTcl
variable Initialised 0
proc LogError {message} {
puts stderr $message
}
# Constructs the full mappings between Tcl and ICU names for encodings.
proc Init {} {
variable tclToIcu
variable icuToTcl
variable Initialised
if {$Initialised} {
return
} else {
set initialised 1
}
# There are some special cases where names do not line up
# at all. Map Tcl -> ICU
array set specialCases {
ebcdic ebcdic-cp-us
macCentEuro maccentraleurope
utf16 UTF16_PlatformEndian
utf-16be UnicodeBig
utf-16le UnicodeLittle
utf32 UTF32_PlatformEndian
}
# Ignore all errors. Do not want to hold up Tcl
# if ICU not available
try {
foreach tclName [encoding names] {
try {
set icuNames [aliases $tclName]
} on error errMsg {
LogError "Could not get aliases for $tclName: $errMsg"
continue
}
if {[llength $icuNames] == 0} {
# E.g. macGreek -> x-MacGreek
set icuNames [aliases x-$tclName]
if {[llength $icuNames] == 0} {
# Still no joy, check for special cases
if {[info exists specialCases($tclName)]} {
set icuNames [aliases $specialCases($tclName)]
}
}
}
# If the Tcl name is also an ICU name use it else use
# the first name which is the canonical ICU name
set pos [lsearch -exact -nocase $icuNames $tclName]
if {$pos >= 0} {
lappend tclToIcu($tclName) [lindex $icuNames $pos] \
{*}[lreplace $icuNames $pos $pos]
} else {
set tclToIcu($tclName) $icuNames
}
foreach icuName $icuNames {
lappend icuToTcl($icuName) $tclName
}
}
} on error errMsg {
LogError $errMsg
}
array default set tclToIcu ""
array default set icuToTcl ""
}
# Primarily used during development
proc MappedIcuNames {{pat *}} {
Init
variable icuToTcl
return [array names icuToTcl $pat]
}
|
| ︙ | ︙ | |||
122 123 124 125 126 127 128 |
# the empty string in case not found.
proc icuToTcl {icuName} {
Init
proc icuToTcl {icuName} {
variable icuToTcl
return [lindex $icuToTcl($icuName) 0]
}
| | | | 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 |
# the empty string in case not found.
proc icuToTcl {icuName} {
Init
proc icuToTcl {icuName} {
variable icuToTcl
return [lindex $icuToTcl($icuName) 0]
}
tailcall icuToTcl $icuName
}
# Returns the ICU equivalent of an Tcl encoding name or
# the empty string in case not found.
proc tclToIcu {tclName} {
Init
proc tclToIcu {tclName} {
variable tclToIcu
return [lindex $tclToIcu($tclName) 0]
}
tailcall tclToIcu $tclName
}
namespace export {[a-z]*}
namespace ensemble create
}
|
Changes to library/init.tcl.
| ︙ | ︙ | |||
88 89 90 91 92 93 94 |
}
}
namespace eval tcl::Pkg {}
# Setup the unknown package handler
| < < < < < < < < < < < < < < | 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 |
}
}
namespace eval tcl::Pkg {}
# Setup the unknown package handler
if {[interp issafe]} {
package unknown {::tcl::tm::UnknownHandler ::tclPkgUnknown}
} else {
# Set up search for Tcl Modules (TIP #189).
# and setup platform specific unknown package handlers
if {$tcl_platform(os) eq "Darwin"
&& $tcl_platform(platform) eq "unix"} {
package unknown {::tcl::tm::UnknownHandler \
{::tcl::MacOSXPkgUnknown ::tclPkgUnknown}}
} else {
package unknown {::tcl::tm::UnknownHandler ::tclPkgUnknown}
}
}
# Conditionalize for presence of exec.
if {[namespace which -command exec] eq ""} {
# Some machines do not have exec. Also, on all
|
| ︙ | ︙ |
Changes to tests/interp.test.
| ︙ | ︙ | |||
16 17 18 19 20 21 22 | } ::tcltest::loadTestedCommands catch [list package require -exact tcl::test [info patchlevel]] testConstraint testinterpdelete [llength [info commands testinterpdelete]] | > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
}
::tcltest::loadTestedCommands
catch [list package require -exact tcl::test [info patchlevel]]
testConstraint testinterpdelete [llength [info commands testinterpdelete]]
set hidden_cmds [list {*}{
cd clock encoding exec exit fconfigure file glob load open pwd socket source
tcl:clock:add tcl:clock:format tcl:clock:scan
tcl:encoding:dirs tcl:encoding:system
tcl:file:atime tcl:file:attributes tcl:file:copy tcl:file:delete
tcl:file:dirname tcl:file:executable tcl:file:exists tcl:file:extension
tcl:file:home tcl:file:isdirectory tcl:file:isfile tcl:file:link
tcl:file:lstat tcl:file:mkdir tcl:file:mtime tcl:file:nativename
tcl:file:normalize tcl:file:owned tcl:file:readable tcl:file:readlink
tcl:file:rename tcl:file:rootname tcl:file:size tcl:file:stat tcl:file:tail
tcl:file:tempdir tcl:file:tempfile tcl:file:tildeexpand tcl:file:type
tcl:file:volumes tcl:file:writable
tcl:info:cmdtype tcl:info:nameofexecutable
tcl:process:autopurge tcl:process:list tcl:process:purge tcl:process:status
tcl:unsupported:disassemble tcl:unsupported:getbytecode
tcl:unsupported:loadIcu tcl:unsupported:representation
tcl:zipfs:canonical tcl:zipfs:exists tcl:zipfs:info tcl:zipfs:list
tcl:zipfs:lmkimg tcl:zipfs:lmkzip tcl:zipfs:mkimg tcl:zipfs:mkkey
tcl:zipfs:mkzip tcl:zipfs:mount tcl:zipfs:mountdata tcl:zipfs:root
tcl:zipfs:unmount
unload zipfs
}]
proc _ms_limit_args {ms {t0 {}}} {
if {$t0 eq {}} { set t0 [clock milliseconds] }
incr t0 $ms
list -seconds [expr {$t0 / 1000}] -milliseconds [expr {$t0 % 1000}]
}
|
| ︙ | ︙ |
Changes to tests/namespace.test.
| ︙ | ︙ | |||
3369 3370 3371 3372 3373 3374 3375 3376 3377 |
test namespace-55.1 {compiled ensembles inside compiled ensembles: Bug 6d2f249a01} {
info class [format %s constructor] oo::object
} ""
test namespace-55.2 {compiled ensembles inside safe interpreters (for safe sub-commands), bug [1095bf7f756f9aed]} -setup {
interp create -safe si
set code {
proc test_comp_dict d { dict for {k v} $d {expr $v} }
| > > > > > > > > > < < | | | > | 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 |
test namespace-55.1 {compiled ensembles inside compiled ensembles: Bug 6d2f249a01} {
info class [format %s constructor] oo::object
} ""
test namespace-55.2 {compiled ensembles inside safe interpreters (for safe sub-commands), bug [1095bf7f756f9aed]} -setup {
interp create -safe si
proc findBytecode {setup descriptor} {
foreach op [dict values [dict get $descriptor instructions]] {
if {[lindex $op 0] eq "dictFirst"} {
return $op
}
}
return [join [dict get $descriptor instructions] "\n"]
}
} -body {
set code {
proc test_comp_dict d { dict for {k v} $d {expr $v} }
}
set a [findBytecode [ eval $code] [::tcl::unsupported::getbytecode proc test_comp_dict]]
set b [findBytecode [si eval $code] [si invokehidden tcl:unsupported:getbytecode proc test_comp_dict]]
list [expr {$a eq $b}] [expr {"dictFirst" in $a}] [expr {"dictFirst" in $b}] $a $b
} -cleanup {
rename test_comp_dict {}
rename findBytecode {}
unset -nocomplain code a b
interp delete si
} -match glob -result {1 1 1 *}
test namespace-56.1 {bug f97d4ee020: mutually-entangled deletion} {
namespace eval ::testing {
proc abc {} {}
|
| ︙ | ︙ |