1 /*
2 * tclPkg.c --
3 *
4 * This file implements package and version control for Tcl via the
5 * "package" command and a few C APIs.
6 *
7 * Copyright © 1996 Sun Microsystems, Inc.
8 * Copyright © 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net>
9 *
10 * See the file "license.terms" for information on usage and redistribution of
11 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
12 *
13 * TIP #268.
14 * Heavily rewritten to handle the extend version numbers, and extended
15 * package requirements.
16 */
17
18 #include "tclInt.h"
19
20 MODULE_SCOPE char *tclEmptyStringRep;
21
22 char *tclEmptyStringRep = &tclEmptyString;
23
24 /*
25 * Each invocation of the "package ifneeded" command creates a structure of
26 * the following type, which is used to load the package into the interpreter
27 * if it is requested with a "package require" command.
28 */
29
30 typedef struct PkgAvail {
31 char *version; /* Version string; malloc'ed. */
32 char *script; /* Script to invoke to provide this version of
33 * the package. Malloc'ed and protected by
34 * Tcl_Preserve and Tcl_Release. */
35 char *pkgIndex; /* Full file name of pkgIndex file */
36 struct PkgAvail *nextPtr; /* Next in list of available versions of the
37 * same package. */
38 } PkgAvail;
39
40 typedef struct PkgName {
41 struct PkgName *nextPtr; /* Next in list of package names being
42 * initialized. */
43 char name[1];
44 } PkgName;
45
46 typedef struct PkgFiles {
47 PkgName *names; /* Package names being initialized. Must be
48 * first field. */
49 Tcl_HashTable table; /* Table which contains files for each
50 * package. */
51 } PkgFiles;
52
53 /*
54 * For each package that is known in any way to an interpreter, there is one
55 * record of the following type. These records are stored in the
56 * "packageTable" hash table in the interpreter, keyed by package name such as
57 * "Tk" (no version number).
58 */
59
60 typedef struct Package {
61 Tcl_Obj *version;
62 PkgAvail *availPtr; /* First in list of all available versions of
63 * this package. */
64 const void *clientData; /* Client data. */
65 } Package;
66
67 typedef struct Require {
68 void *clientDataPtr;
69 const char *name;
70 Package *pkgPtr;
71 char *versionToProvide;
72 } Require;
73
74 typedef struct RequireProcArgs {
75 const char *name;
76 void *clientDataPtr;
77 } RequireProcArgs;
78
79 /*
80 * Prototypes for functions defined in this file:
81 */
82
83 static int CheckVersionAndConvert(Tcl_Interp *interp,
84 const char *string, char **internal, int *stable);
85 static int CompareVersions(char *v1i, char *v2i,
86 int *isMajorPtr);
87 static int CheckRequirement(Tcl_Interp *interp,
88 const char *string);
89 static int CheckAllRequirements(Tcl_Interp *interp, int reqc,
90 Tcl_Obj *const reqv[]);
91 static int RequirementSatisfied(char *havei, const char *req);
92 static int SomeRequirementSatisfied(char *havei, int reqc,
93 Tcl_Obj *const reqv[]);
94 static void AddRequirementsToResult(Tcl_Interp *interp, int reqc,
95 Tcl_Obj *const reqv[]);
96 static void AddRequirementsToDString(Tcl_DString *dstring,
97 int reqc, Tcl_Obj *const reqv[]);
98 static Package * FindPackage(Tcl_Interp *interp, const char *name);
99 static int PkgRequireCore(ClientData data[], Tcl_Interp *interp, int result);
100 static int PkgRequireCoreFinal(ClientData data[], Tcl_Interp *interp, int result);
101 static int PkgRequireCoreCleanup(ClientData data[], Tcl_Interp *interp, int result);
102 static int PkgRequireCoreStep1(ClientData data[], Tcl_Interp *interp, int result);
103 static int PkgRequireCoreStep2(ClientData data[], Tcl_Interp *interp, int result);
104 static int TclNRPkgRequireProc(ClientData clientData, Tcl_Interp *interp, int reqc, Tcl_Obj *const reqv[]);
105 static int SelectPackage(ClientData data[], Tcl_Interp *interp, int result);
106 static int SelectPackageFinal(ClientData data[], Tcl_Interp *interp, int result);
107 static int TclNRPackageObjCmdCleanup(ClientData data[], Tcl_Interp *interp, int result);
108
109 /*
110 * Helper macros.
111 */
112
113 #define DupBlock(v,s,len) \
114 ((v) = (char *)ckalloc(len), memcpy((v),(s),(len)))
115 #define DupString(v,s) \
116 do { \
117 size_t local__len = strlen(s) + 1; \
118 DupBlock((v),(s),local__len); \
119 } while (0)
120
121 /*
122 *----------------------------------------------------------------------
123 *
124 * Tcl_PkgProvide / Tcl_PkgProvideEx --
125 *
126 * This function is invoked to declare that a particular version of a
127 * particular package is now present in an interpreter. There must not be
128 * any other version of this package already provided in the interpreter.
129 *
130 * Results:
131 * Normally returns TCL_OK; if there is already another version of the
132 * package loaded then TCL_ERROR is returned and an error message is left
133 * in the interp's result.
134 *
135 * Side effects:
136 * The interpreter remembers that this package is available, so that no
137 * other version of the package may be provided for the interpreter.
138 *
139 *----------------------------------------------------------------------
140 */
141
142 #undef Tcl_PkgProvide
143 int
Tcl_PkgProvide(Tcl_Interp * interp,const char * name,const char * version)144 Tcl_PkgProvide(
145 Tcl_Interp *interp, /* Interpreter in which package is now
146 * available. */
147 const char *name, /* Name of package. */
148 const char *version) /* Version string for package. */
149 {
150 return Tcl_PkgProvideEx(interp, name, version, NULL);
151 }
152
153 int
Tcl_PkgProvideEx(Tcl_Interp * interp,const char * name,const char * version,const void * clientData)154 Tcl_PkgProvideEx(
155 Tcl_Interp *interp, /* Interpreter in which package is now
156 * available. */
157 const char *name, /* Name of package. */
158 const char *version, /* Version string for package. */
159 const void *clientData) /* clientdata for this package (normally used
160 * for C callback function table) */
161 {
162 Package *pkgPtr;
163 char *pvi, *vi;
164 int res;
165
166 pkgPtr = FindPackage(interp, name);
167 if (pkgPtr->version == NULL) {
168 pkgPtr->version = Tcl_NewStringObj(version, -1);
169 Tcl_IncrRefCount(pkgPtr->version);
170 pkgPtr->clientData = clientData;
171 return TCL_OK;
172 }
173
174 if (CheckVersionAndConvert(interp, Tcl_GetString(pkgPtr->version), &pvi,
175 NULL) != TCL_OK) {
176 return TCL_ERROR;
177 } else if (CheckVersionAndConvert(interp, version, &vi, NULL) != TCL_OK) {
178 ckfree(pvi);
179 return TCL_ERROR;
180 }
181
182 res = CompareVersions(pvi, vi, NULL);
183 ckfree(pvi);
184 ckfree(vi);
185
186 if (res == 0) {
187 if (clientData != NULL) {
188 pkgPtr->clientData = clientData;
189 }
190 return TCL_OK;
191 }
192 Tcl_SetObjResult(interp, Tcl_ObjPrintf(
193 "conflicting versions provided for package \"%s\": %s, then %s",
194 name, Tcl_GetString(pkgPtr->version), version));
195 Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT", NULL);
196 return TCL_ERROR;
197 }
198
199 /*
200 *----------------------------------------------------------------------
201 *
202 * Tcl_PkgRequire / Tcl_PkgRequireEx / Tcl_PkgRequireProc --
203 *
204 * This function is called by code that depends on a particular version
205 * of a particular package. If the package is not already provided in the
206 * interpreter, this function invokes a Tcl script to provide it. If the
207 * package is already provided, this function makes sure that the
208 * caller's needs don't conflict with the version that is present.
209 *
210 * Results:
211 * If successful, returns the version string for the currently provided
212 * version of the package, which may be different from the "version"
213 * argument. If the caller's requirements cannot be met (e.g. the version
214 * requested conflicts with a currently provided version, or the required
215 * version cannot be found, or the script to provide the required version
216 * generates an error), NULL is returned and an error message is left in
217 * the interp's result.
218 *
219 * Side effects:
220 * The script from some previous "package ifneeded" command may be
221 * invoked to provide the package.
222 *
223 *----------------------------------------------------------------------
224 */
225
226 static void
PkgFilesCleanupProc(ClientData clientData,TCL_UNUSED (Tcl_Interp *))227 PkgFilesCleanupProc(
228 ClientData clientData,
229 TCL_UNUSED(Tcl_Interp *))
230 {
231 PkgFiles *pkgFiles = (PkgFiles *) clientData;
232 Tcl_HashSearch search;
233 Tcl_HashEntry *entry;
234
235 while (pkgFiles->names) {
236 PkgName *name = pkgFiles->names;
237
238 pkgFiles->names = name->nextPtr;
239 ckfree(name);
240 }
241 entry = Tcl_FirstHashEntry(&pkgFiles->table, &search);
242 while (entry) {
243 Tcl_Obj *obj = (Tcl_Obj *)Tcl_GetHashValue(entry);
244
245 Tcl_DecrRefCount(obj);
246 entry = Tcl_NextHashEntry(&search);
247 }
248 Tcl_DeleteHashTable(&pkgFiles->table);
249 ckfree(pkgFiles);
250 return;
251 }
252
253 void *
TclInitPkgFiles(Tcl_Interp * interp)254 TclInitPkgFiles(
255 Tcl_Interp *interp)
256 {
257 /*
258 * If assocdata "tclPkgFiles" doesn't exist yet, create it.
259 */
260
261 PkgFiles *pkgFiles = (PkgFiles *)Tcl_GetAssocData(interp, "tclPkgFiles", NULL);
262
263 if (!pkgFiles) {
264 pkgFiles = (PkgFiles *)ckalloc(sizeof(PkgFiles));
265 pkgFiles->names = NULL;
266 Tcl_InitHashTable(&pkgFiles->table, TCL_STRING_KEYS);
267 Tcl_SetAssocData(interp, "tclPkgFiles", PkgFilesCleanupProc, pkgFiles);
268 }
269 return pkgFiles;
270 }
271
272 void
TclPkgFileSeen(Tcl_Interp * interp,const char * fileName)273 TclPkgFileSeen(
274 Tcl_Interp *interp,
275 const char *fileName)
276 {
277 PkgFiles *pkgFiles = (PkgFiles *)
278 Tcl_GetAssocData(interp, "tclPkgFiles", NULL);
279
280 if (pkgFiles && pkgFiles->names) {
281 const char *name = pkgFiles->names->name;
282 Tcl_HashTable *table = &pkgFiles->table;
283 int isNew;
284 Tcl_HashEntry *entry = (Tcl_HashEntry *)Tcl_CreateHashEntry(table, name, &isNew);
285 Tcl_Obj *list;
286
287 if (isNew) {
288 TclNewObj(list);
289 Tcl_SetHashValue(entry, list);
290 Tcl_IncrRefCount(list);
291 } else {
292 list = (Tcl_Obj *)Tcl_GetHashValue(entry);
293 }
294 Tcl_ListObjAppendElement(interp, list, Tcl_NewStringObj(fileName, -1));
295 }
296 }
297
298 #undef Tcl_PkgRequire
299 const char *
Tcl_PkgRequire(Tcl_Interp * interp,const char * name,const char * version,int exact)300 Tcl_PkgRequire(
301 Tcl_Interp *interp, /* Interpreter in which package is now
302 * available. */
303 const char *name, /* Name of desired package. */
304 const char *version, /* Version string for desired version; NULL
305 * means use the latest version available. */
306 int exact) /* Non-zero means that only the particular
307 * version given is acceptable. Zero means use
308 * the latest compatible version. */
309 {
310 return Tcl_PkgRequireEx(interp, name, version, exact, NULL);
311 }
312
313 const char *
Tcl_PkgRequireEx(Tcl_Interp * interp,const char * name,const char * version,int exact,void * clientDataPtr)314 Tcl_PkgRequireEx(
315 Tcl_Interp *interp, /* Interpreter in which package is now
316 * available. */
317 const char *name, /* Name of desired package. */
318 const char *version, /* Version string for desired version; NULL
319 * means use the latest version available. */
320 int exact, /* Non-zero means that only the particular
321 * version given is acceptable. Zero means use
322 * the latest compatible version. */
323 void *clientDataPtr) /* Used to return the client data for this
324 * package. If it is NULL then the client data
325 * is not returned. This is unchanged if this
326 * call fails for any reason. */
327 {
328 Tcl_Obj *ov;
329 const char *result = NULL;
330
331 /*
332 * If an attempt is being made to load this into a standalone executable
333 * on a platform where backlinking is not supported then this must be a
334 * shared version of Tcl (Otherwise the load would have failed). Detect
335 * this situation by checking that this library has been correctly
336 * initialised. If it has not been then return immediately as nothing will
337 * work.
338 */
339
340 if (tclEmptyStringRep == NULL) {
341 /*
342 * OK, so what's going on here?
343 *
344 * First, what are we doing? We are performing a check on behalf of
345 * one particular caller, Tcl_InitStubs(). When a package is stub-
346 * enabled, it is statically linked to libtclstub.a, which contains a
347 * copy of Tcl_InitStubs(). When a stub-enabled package is loaded, its
348 * *_Init() function is supposed to call Tcl_InitStubs() before
349 * calling any other functions in the Tcl library. The first Tcl
350 * function called by Tcl_InitStubs() through the stub table is
351 * Tcl_PkgRequireEx(), so this code right here is the first code that
352 * is part of the original Tcl library in the executable that gets
353 * executed on behalf of a newly loaded stub-enabled package.
354 *
355 * One easy error for the developer/builder of a stub-enabled package
356 * to make is to forget to define USE_TCL_STUBS when compiling the
357 * package. When that happens, the package will contain symbols that
358 * are references to the Tcl library, rather than function pointers
359 * referencing the stub table. On platforms that lack backlinking,
360 * those unresolved references may cause the loading of the package to
361 * also load a second copy of the Tcl library, leading to all kinds of
362 * trouble. We would like to catch that error and report a useful
363 * message back to the user. That's what we're doing.
364 *
365 * Second, how does this work? If we reach this point, then the global
366 * variable tclEmptyStringRep has the value NULL. Compare that with
367 * the definition of tclEmptyStringRep near the top of this file. It
368 * clearly should not have the value NULL; it should point to the char
369 * tclEmptyString. If we see it having the value NULL, then somehow we
370 * are seeing a Tcl library that isn't completely initialized, and
371 * that's an indicator for the error condition described above.
372 * (Further explanation is welcome.)
373 *
374 * Third, so what do we do about it? This situation indicates the
375 * package we just loaded wasn't properly compiled to be stub-enabled,
376 * yet it thinks it is stub-enabled (it called Tcl_InitStubs()). We
377 * want to report that the package just loaded is broken, so we want
378 * to place an error message in the interpreter result and return NULL
379 * to indicate failure to Tcl_InitStubs() so that it will also fail.
380 * (Further explanation why we don't want to Tcl_Panic() is welcome.
381 * After all, two Tcl libraries can't be a good thing!)
382 *
383 * Trouble is that's going to be tricky. We're now using a Tcl library
384 * that's not fully initialized. Functions in it may not work
385 * reliably, so be very careful about adding any other calls here
386 * without checking how they behave when initialization is incomplete.
387 */
388
389 Tcl_SetObjResult(interp, Tcl_ObjPrintf(
390 "Cannot load package \"%s\" in standalone executable:"
391 " This package is not compiled with stub support", name));
392 Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNSTUBBED", NULL);
393 return NULL;
394 }
395
396 /*
397 * Translate between old and new API, and defer to the new function.
398 */
399
400 if (version == NULL) {
401 if (Tcl_PkgRequireProc(interp, name, 0, NULL, clientDataPtr) == TCL_OK) {
402 result = Tcl_GetString(Tcl_GetObjResult(interp));
403 Tcl_ResetResult(interp);
404 }
405 } else {
406 if (exact && TCL_OK
407 != CheckVersionAndConvert(interp, version, NULL, NULL)) {
408 return NULL;
409 }
410 ov = Tcl_NewStringObj(version, -1);
411 if (exact) {
412 Tcl_AppendStringsToObj(ov, "-", version, NULL);
413 }
414 Tcl_IncrRefCount(ov);
415 if (Tcl_PkgRequireProc(interp, name, 1, &ov, clientDataPtr) == TCL_OK) {
416 result = Tcl_GetString(Tcl_GetObjResult(interp));
417 Tcl_ResetResult(interp);
418 }
419 TclDecrRefCount(ov);
420 }
421 return result;
422 }
423
424 int
Tcl_PkgRequireProc(Tcl_Interp * interp,const char * name,int reqc,Tcl_Obj * const reqv[],void * clientDataPtr)425 Tcl_PkgRequireProc(
426 Tcl_Interp *interp, /* Interpreter in which package is now
427 * available. */
428 const char *name, /* Name of desired package. */
429 int reqc, /* Requirements constraining the desired
430 * version. */
431 Tcl_Obj *const reqv[], /* 0 means to use the latest version
432 * available. */
433 void *clientDataPtr)
434 {
435 RequireProcArgs args;
436
437 args.name = name;
438 args.clientDataPtr = clientDataPtr;
439 return Tcl_NRCallObjProc(interp,
440 TclNRPkgRequireProc, (void *) &args, reqc, reqv);
441 }
442
443 static int
TclNRPkgRequireProc(ClientData clientData,Tcl_Interp * interp,int reqc,Tcl_Obj * const reqv[])444 TclNRPkgRequireProc(
445 ClientData clientData,
446 Tcl_Interp *interp,
447 int reqc,
448 Tcl_Obj *const reqv[])
449 {
450 RequireProcArgs *args = (RequireProcArgs *)clientData;
451
452 Tcl_NRAddCallback(interp,
453 PkgRequireCore, (void *) args->name, INT2PTR(reqc), (void *) reqv,
454 args->clientDataPtr);
455 return TCL_OK;
456 }
457
458 static int
PkgRequireCore(ClientData data[],Tcl_Interp * interp,TCL_UNUSED (int))459 PkgRequireCore(
460 ClientData data[],
461 Tcl_Interp *interp,
462 TCL_UNUSED(int))
463 {
464 const char *name = (const char *)data[0];
465 int reqc = PTR2INT(data[1]);
466 Tcl_Obj **reqv = (Tcl_Obj **)data[2];
467 int code = CheckAllRequirements(interp, reqc, reqv);
468 Require *reqPtr;
469
470 if (code != TCL_OK) {
471 return code;
472 }
473 reqPtr = (Require *)ckalloc(sizeof(Require));
474 Tcl_NRAddCallback(interp, PkgRequireCoreCleanup, reqPtr, NULL, NULL, NULL);
475 reqPtr->clientDataPtr = data[3];
476 reqPtr->name = name;
477 reqPtr->pkgPtr = FindPackage(interp, name);
478 if (reqPtr->pkgPtr->version == NULL) {
479 Tcl_NRAddCallback(interp,
480 SelectPackage, reqPtr, INT2PTR(reqc), reqv,
481 (void *)PkgRequireCoreStep1);
482 } else {
483 Tcl_NRAddCallback(interp,
484 PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), reqv, NULL);
485 }
486 return TCL_OK;
487 }
488
489 static int
PkgRequireCoreStep1(ClientData data[],Tcl_Interp * interp,TCL_UNUSED (int))490 PkgRequireCoreStep1(
491 ClientData data[],
492 Tcl_Interp *interp,
493 TCL_UNUSED(int))
494 {
495 Tcl_DString command;
496 char *script;
497 Require *reqPtr = (Require *)data[0];
498 int reqc = PTR2INT(data[1]);
499 Tcl_Obj **const reqv = (Tcl_Obj **)data[2];
500 const char *name = reqPtr->name /* Name of desired package. */;
501
502 /*
503 * If we've got the package in the DB already, go on to actually loading
504 * it.
505 */
506
507 if (reqPtr->pkgPtr->version != NULL) {
508 Tcl_NRAddCallback(interp,
509 PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), (void *)reqv, NULL);
510 return TCL_OK;
511 }
512
513 /*
514 * The package is not in the database. If there is a "package unknown"
515 * command, invoke it.
516 */
517
518 script = ((Interp *) interp)->packageUnknown;
519 if (script == NULL) {
520 /*
521 * No package unknown script. Move on to finalizing.
522 */
523
524 Tcl_NRAddCallback(interp,
525 PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), (void *)reqv, NULL);
526 return TCL_OK;
527 }
528
529 /*
530 * Invoke the "package unknown" script synchronously.
531 */
532
533 Tcl_DStringInit(&command);
534 Tcl_DStringAppend(&command, script, -1);
535 Tcl_DStringAppendElement(&command, name);
536 AddRequirementsToDString(&command, reqc, reqv);
537
538 Tcl_NRAddCallback(interp,
539 PkgRequireCoreStep2, reqPtr, INT2PTR(reqc), (void *) reqv, NULL);
540 Tcl_NREvalObj(interp,
541 Tcl_NewStringObj(Tcl_DStringValue(&command),
542 Tcl_DStringLength(&command)),
543 TCL_EVAL_GLOBAL);
544 Tcl_DStringFree(&command);
545 return TCL_OK;
546 }
547
548 static int
PkgRequireCoreStep2(ClientData data[],Tcl_Interp * interp,int result)549 PkgRequireCoreStep2(
550 ClientData data[],
551 Tcl_Interp *interp,
552 int result)
553 {
554 Require *reqPtr = (Require *)data[0];
555 int reqc = PTR2INT(data[1]);
556 Tcl_Obj **const reqv = (Tcl_Obj **)data[2];
557 const char *name = reqPtr->name; /* Name of desired package. */
558
559 if ((result != TCL_OK) && (result != TCL_ERROR)) {
560 Tcl_SetObjResult(interp, Tcl_ObjPrintf(
561 "bad return code: %d", result));
562 Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL);
563 result = TCL_ERROR;
564 }
565 if (result == TCL_ERROR) {
566 Tcl_AddErrorInfo(interp,
567 "\n (\"package unknown\" script)");
568 return result;
569 }
570 Tcl_ResetResult(interp);
571
572 /*
573 * pkgPtr may now be invalid, so refresh it.
574 */
575
576 reqPtr->pkgPtr = FindPackage(interp, name);
577 Tcl_NRAddCallback(interp,
578 SelectPackage, reqPtr, INT2PTR(reqc), reqv,
579 (void *)PkgRequireCoreFinal);
580 return TCL_OK;
581 }
582
583 static int
PkgRequireCoreFinal(ClientData data[],Tcl_Interp * interp,TCL_UNUSED (int))584 PkgRequireCoreFinal(
585 ClientData data[],
586 Tcl_Interp *interp,
587 TCL_UNUSED(int))
588 {
589 Require *reqPtr = (Require *)data[0];
590 int reqc = PTR2INT(data[1]), satisfies;
591 Tcl_Obj **const reqv = (Tcl_Obj **)data[2];
592 char *pkgVersionI;
593 void *clientDataPtr = reqPtr->clientDataPtr;
594 const char *name = reqPtr->name; /* Name of desired package. */
595
596 if (reqPtr->pkgPtr->version == NULL) {
597 Tcl_SetObjResult(interp, Tcl_ObjPrintf(
598 "can't find package %s", name));
599 Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNFOUND", NULL);
600 AddRequirementsToResult(interp, reqc, reqv);
601 return TCL_ERROR;
602 }
603
604 /*
605 * Ensure that the provided version meets the current requirements.
606 */
607
608 if (reqc != 0) {
609 CheckVersionAndConvert(interp, Tcl_GetString(reqPtr->pkgPtr->version),
610 &pkgVersionI, NULL);
611 satisfies = SomeRequirementSatisfied(pkgVersionI, reqc, reqv);
612
613 ckfree(pkgVersionI);
614
615 if (!satisfies) {
616 Tcl_SetObjResult(interp, Tcl_ObjPrintf(
617 "version conflict for package \"%s\": have %s, need",
618 name, Tcl_GetString(reqPtr->pkgPtr->version)));
619 Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT",
620 NULL);
621 AddRequirementsToResult(interp, reqc, reqv);
622 return TCL_ERROR;
623 }
624 }
625
626 if (clientDataPtr) {
627 const void **ptr = (const void **) clientDataPtr;
628
629 *ptr = reqPtr->pkgPtr->clientData;
630 }
631 Tcl_SetObjResult(interp, reqPtr->pkgPtr->version);
632 return TCL_OK;
633 }
634
635 static int
PkgRequireCoreCleanup(ClientData data[],TCL_UNUSED (Tcl_Interp *),int result)636 PkgRequireCoreCleanup(
637 ClientData data[],
638 TCL_UNUSED(Tcl_Interp *),
639 int result)
640 {
641 ckfree(data[0]);
642 return result;
643 }
644
645 static int
SelectPackage(ClientData data[],Tcl_Interp * interp,TCL_UNUSED (int))646 SelectPackage(
647 ClientData data[],
648 Tcl_Interp *interp,
649 TCL_UNUSED(int))
650 {
651 PkgAvail *availPtr, *bestPtr, *bestStablePtr;
652 char *availVersion, *bestVersion, *bestStableVersion;
653 /* Internal rep. of versions */
654 int availStable, satisfies;
655 Require *reqPtr = (Require *)data[0];
656 int reqc = PTR2INT(data[1]);
657 Tcl_Obj **const reqv = (Tcl_Obj **)data[2];
658 const char *name = reqPtr->name;
659 Package *pkgPtr = reqPtr->pkgPtr;
660 Interp *iPtr = (Interp *) interp;
661
662 /*
663 * Check whether we're already attempting to load some version of this
664 * package (circular dependency detection).
665 */
666
667 if (pkgPtr->clientData != NULL) {
668 Tcl_SetObjResult(interp, Tcl_ObjPrintf(
669 "circular package dependency:"
670 " attempt to provide %s %s requires %s",
671 name, (char *) pkgPtr->clientData, name));
672 AddRequirementsToResult(interp, reqc, reqv);
673 Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "CIRCULARITY", NULL);
674 return TCL_ERROR;
675 }
676
677 /*
678 * The package isn't yet present. Search the list of available versions
679 * and invoke the script for the best available version. We are actually
680 * locating the best, and the best stable version. One of them is then
681 * chosen based on the selection mode.
682 */
683
684 bestPtr = NULL;
685 bestStablePtr = NULL;
686 bestVersion = NULL;
687 bestStableVersion = NULL;
688
689 for (availPtr = pkgPtr->availPtr; availPtr != NULL;
690 availPtr = availPtr->nextPtr) {
691 if (CheckVersionAndConvert(interp, availPtr->version,
692 &availVersion, &availStable) != TCL_OK) {
693 /*
694 * The provided version number has invalid syntax. This should not
695 * happen. This should have been caught by the 'package ifneeded'
696 * registering the package.
697 */
698
699 continue;
700 }
701
702 /*
703 * Check satisfaction of requirements before considering the current
704 * version further.
705 */
706
707 if (reqc > 0) {
708 satisfies = SomeRequirementSatisfied(availVersion, reqc, reqv);
709 if (!satisfies) {
710 ckfree(availVersion);
711 availVersion = NULL;
712 continue;
713 }
714 }
715
716 if (bestPtr != NULL) {
717 int res = CompareVersions(availVersion, bestVersion, NULL);
718
719 /*
720 * Note: Used internal reps in the comparison!
721 */
722
723 if (res > 0) {
724 /*
725 * The version of the package sought is better than the
726 * currently selected version.
727 */
728
729 ckfree(bestVersion);
730 bestVersion = NULL;
731 goto newbest;
732 }
733 } else {
734 newbest:
735 /*
736 * We have found a version which is better than our max.
737 */
738
739 bestPtr = availPtr;
740 CheckVersionAndConvert(interp, bestPtr->version, &bestVersion, NULL);
741 }
742
743 if (!availStable) {
744 ckfree(availVersion);
745 availVersion = NULL;
746 continue;
747 }
748
749 if (bestStablePtr != NULL) {
750 int res = CompareVersions(availVersion, bestStableVersion, NULL);
751
752 /*
753 * Note: Used internal reps in the comparison!
754 */
755
756 if (res > 0) {
757 /*
758 * This stable version of the package sought is better than
759 * the currently selected stable version.
760 */
761
762 ckfree(bestStableVersion);
763 bestStableVersion = NULL;
764 goto newstable;
765 }
766 } else {
767 newstable:
768 /*
769 * We have found a stable version which is better than our max
770 * stable.
771 */
772
773 bestStablePtr = availPtr;
774 CheckVersionAndConvert(interp, bestStablePtr->version,
775 &bestStableVersion, NULL);
776 }
777
778 ckfree(availVersion);
779 availVersion = NULL;
780 } /* end for */
781
782 /*
783 * Clean up memorized internal reps, if any.
784 */
785
786 if (bestVersion != NULL) {
787 ckfree(bestVersion);
788 bestVersion = NULL;
789 }
790
791 if (bestStableVersion != NULL) {
792 ckfree(bestStableVersion);
793 bestStableVersion = NULL;
794 }
795
796 /*
797 * Now choose a version among the two best. For 'latest' we simply take
798 * (actually keep) the best. For 'stable' we take the best stable, if
799 * there is any, or the best if there is nothing stable.
800 */
801
802 if ((iPtr->packagePrefer == PKG_PREFER_STABLE)
803 && (bestStablePtr != NULL)) {
804 bestPtr = bestStablePtr;
805 }
806
807 if (bestPtr == NULL) {
808 Tcl_NRAddCallback(interp,
809 (Tcl_NRPostProc *)data[3], reqPtr, INT2PTR(reqc), (void *)reqv, NULL);
810 } else {
811 /*
812 * We found an ifneeded script for the package. Be careful while
813 * executing it: this could cause reentrancy, so (a) protect the
814 * script itself from deletion and (b) don't assume that bestPtr will
815 * still exist when the script completes.
816 */
817
818 char *versionToProvide = bestPtr->version;
819 PkgFiles *pkgFiles;
820 PkgName *pkgName;
821
822 Tcl_Preserve(versionToProvide);
823 pkgPtr->clientData = versionToProvide;
824
825 pkgFiles = (PkgFiles *)TclInitPkgFiles(interp);
826
827 /*
828 * Push "ifneeded" package name in "tclPkgFiles" assocdata.
829 */
830
831 pkgName = (PkgName *)ckalloc(sizeof(PkgName) + strlen(name));
832 pkgName->nextPtr = pkgFiles->names;
833 strcpy(pkgName->name, name);
834 pkgFiles->names = pkgName;
835 if (bestPtr->pkgIndex) {
836 TclPkgFileSeen(interp, bestPtr->pkgIndex);
837 }
838 reqPtr->versionToProvide = versionToProvide;
839 Tcl_NRAddCallback(interp,
840 SelectPackageFinal, reqPtr, INT2PTR(reqc), (void *)reqv,
841 data[3]);
842 Tcl_NREvalObj(interp, Tcl_NewStringObj(bestPtr->script, -1),
843 TCL_EVAL_GLOBAL);
844 }
845 return TCL_OK;
846 }
847
848 static int
SelectPackageFinal(ClientData data[],Tcl_Interp * interp,int result)849 SelectPackageFinal(
850 ClientData data[],
851 Tcl_Interp *interp,
852 int result)
853 {
854 Require *reqPtr = (Require *)data[0];
855 int reqc = PTR2INT(data[1]);
856 Tcl_Obj **const reqv = (Tcl_Obj **)data[2];
857 const char *name = reqPtr->name;
858 char *versionToProvide = reqPtr->versionToProvide;
859
860 /*
861 * Pop the "ifneeded" package name from "tclPkgFiles" assocdata
862 */
863
864 PkgFiles *pkgFiles = (PkgFiles *)Tcl_GetAssocData(interp, "tclPkgFiles", NULL);
865 PkgName *pkgName = pkgFiles->names;
866 pkgFiles->names = pkgName->nextPtr;
867 ckfree(pkgName);
868
869 reqPtr->pkgPtr = FindPackage(interp, name);
870 if (result == TCL_OK) {
871 Tcl_ResetResult(interp);
872 if (reqPtr->pkgPtr->version == NULL) {
873 result = TCL_ERROR;
874 Tcl_SetObjResult(interp, Tcl_ObjPrintf(
875 "attempt to provide package %s %s failed:"
876 " no version of package %s provided",
877 name, versionToProvide, name));
878 Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNPROVIDED",
879 NULL);
880 } else {
881 char *pvi, *vi;
882
883 if (TCL_OK != CheckVersionAndConvert(interp,
884 Tcl_GetString(reqPtr->pkgPtr->version), &pvi, NULL)) {
885 result = TCL_ERROR;
886 } else if (CheckVersionAndConvert(interp,
887 versionToProvide, &vi, NULL) != TCL_OK) {
888 ckfree(pvi);
889 result = TCL_ERROR;
890 } else {
891 int res = CompareVersions(pvi, vi, NULL);
892
893 ckfree(pvi);
894 ckfree(vi);
895 if (res != 0) {
896 result = TCL_ERROR;
897 Tcl_SetObjResult(interp, Tcl_ObjPrintf(
898 "attempt to provide package %s %s failed:"
899 " package %s %s provided instead",
900 name, versionToProvide,
901 name, Tcl_GetString(reqPtr->pkgPtr->version)));
902 Tcl_SetErrorCode(interp, "TCL", "PACKAGE",
903 "WRONGPROVIDE", NULL);
904 }
905 }
906 }
907 } else if (result != TCL_ERROR) {
908 Tcl_Obj *codePtr;
909
910 TclNewIntObj(codePtr, result);
911 Tcl_SetObjResult(interp, Tcl_ObjPrintf(
912 "attempt to provide package %s %s failed:"
913 " bad return code: %s",
914 name, versionToProvide, TclGetString(codePtr)));
915 Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL);
916 TclDecrRefCount(codePtr);
917 result = TCL_ERROR;
918 }
919
920 if (result == TCL_ERROR) {
921 Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
922 "\n (\"package ifneeded %s %s\" script)",
923 name, versionToProvide));
924 }
925 Tcl_Release(versionToProvide);
926
927 if (result != TCL_OK) {
928 /*
929 * Take a non-TCL_OK code from the script as an indication the package
930 * wasn't loaded properly, so the package system should not remember
931 * an improper load.
932 *
933 * This is consistent with our returning NULL. If we're not willing to
934 * tell our caller we got a particular version, we shouldn't store
935 * that version for telling future callers either.
936 */
937
938 if (reqPtr->pkgPtr->version != NULL) {
939 Tcl_DecrRefCount(reqPtr->pkgPtr->version);
940 reqPtr->pkgPtr->version = NULL;
941 }
942 reqPtr->pkgPtr->clientData = NULL;
943 return result;
944 }
945
946 Tcl_NRAddCallback(interp,
947 (Tcl_NRPostProc *)data[3], reqPtr, INT2PTR(reqc), (void *) reqv, NULL);
948 return TCL_OK;
949 }
950
951 /*
952 *----------------------------------------------------------------------
953 *
954 * Tcl_PkgPresent / Tcl_PkgPresentEx --
955 *
956 * Checks to see whether the specified package is present. If it is not
957 * then no additional action is taken.
958 *
959 * Results:
960 * If successful, returns the version string for the currently provided
961 * version of the package, which may be different from the "version"
962 * argument. If the caller's requirements cannot be met (e.g. the version
963 * requested conflicts with a currently provided version), NULL is
964 * returned and an error message is left in interp->result.
965 *
966 * Side effects:
967 * None.
968 *
969 *----------------------------------------------------------------------
970 */
971
972 #undef Tcl_PkgPresent
973 const char *
Tcl_PkgPresent(Tcl_Interp * interp,const char * name,const char * version,int exact)974 Tcl_PkgPresent(
975 Tcl_Interp *interp, /* Interpreter in which package is now
976 * available. */
977 const char *name, /* Name of desired package. */
978 const char *version, /* Version string for desired version; NULL
979 * means use the latest version available. */
980 int exact) /* Non-zero means that only the particular
981 * version given is acceptable. Zero means use
982 * the latest compatible version. */
983 {
984 return Tcl_PkgPresentEx(interp, name, version, exact, NULL);
985 }
986
987 const char *
Tcl_PkgPresentEx(Tcl_Interp * interp,const char * name,const char * version,int exact,void * clientDataPtr)988 Tcl_PkgPresentEx(
989 Tcl_Interp *interp, /* Interpreter in which package is now
990 * available. */
991 const char *name, /* Name of desired package. */
992 const char *version, /* Version string for desired version; NULL
993 * means use the latest version available. */
994 int exact, /* Non-zero means that only the particular
995 * version given is acceptable. Zero means use
996 * the latest compatible version. */
997 void *clientDataPtr) /* Used to return the client data for this
998 * package. If it is NULL then the client data
999 * is not returned. This is unchanged if this
1000 * call fails for any reason. */
1001 {
1002 Interp *iPtr = (Interp *) interp;
1003 Tcl_HashEntry *hPtr;
1004 Package *pkgPtr;
1005
1006 hPtr = Tcl_FindHashEntry(&iPtr->packageTable, name);
1007 if (hPtr) {
1008 pkgPtr = (Package *)Tcl_GetHashValue(hPtr);
1009 if (pkgPtr->version != NULL) {
1010 /*
1011 * At this point we know that the package is present. Make sure
1012 * that the provided version meets the current requirement by
1013 * calling Tcl_PkgRequireEx() to check for us.
1014 */
1015
1016 const char *foundVersion = Tcl_PkgRequireEx(interp, name, version,
1017 exact, clientDataPtr);
1018
1019 if (foundVersion == NULL) {
1020 Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PACKAGE", name,
1021 NULL);
1022 }
1023 return foundVersion;
1024 }
1025 }
1026
1027 if (version != NULL) {
1028 Tcl_SetObjResult(interp, Tcl_ObjPrintf(
1029 "package %s %s is not present", name, version));
1030 } else {
1031 Tcl_SetObjResult(interp, Tcl_ObjPrintf(
1032 "package %s is not present", name));
1033 }
1034 Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PACKAGE", name, NULL);
1035 return NULL;
1036 }
1037
1038 /*
1039 *----------------------------------------------------------------------
1040 *
1041 * Tcl_PackageObjCmd --
1042 *
1043 * This function is invoked to process the "package" Tcl command. See the
1044 * user documentation for details on what it does.
1045 *
1046 * Results:
1047 * A standard Tcl result.
1048 *
1049 * Side effects:
1050 * See the user documentation.
1051 *
1052 *----------------------------------------------------------------------
1053 */
1054 int
Tcl_PackageObjCmd(ClientData clientData,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])1055 Tcl_PackageObjCmd(
1056 ClientData clientData,
1057 Tcl_Interp *interp, /* Current interpreter. */
1058 int objc, /* Number of arguments. */
1059 Tcl_Obj *const objv[]) /* Argument objects. */
1060 {
1061 return Tcl_NRCallObjProc(interp, TclNRPackageObjCmd, clientData, objc, objv);
1062 }
1063
1064 int
TclNRPackageObjCmd(TCL_UNUSED (ClientData),Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])1065 TclNRPackageObjCmd(
1066 TCL_UNUSED(ClientData),
1067 Tcl_Interp *interp, /* Current interpreter. */
1068 int objc, /* Number of arguments. */
1069 Tcl_Obj *const objv[]) /* Argument objects. */
1070 {
1071 static const char *const pkgOptions[] = {
1072 "files", "forget", "ifneeded", "names", "prefer",
1073 "present", "provide", "require", "unknown", "vcompare",
1074 "versions", "vsatisfies", NULL
1075 };
1076 enum pkgOptionsEnum {
1077 PKG_FILES, PKG_FORGET, PKG_IFNEEDED, PKG_NAMES, PKG_PREFER,
1078 PKG_PRESENT, PKG_PROVIDE, PKG_REQUIRE, PKG_UNKNOWN, PKG_VCOMPARE,
1079 PKG_VERSIONS, PKG_VSATISFIES
1080 };
1081 Interp *iPtr = (Interp *) interp;
1082 int optionIndex, exact, i, newobjc, satisfies;
1083 PkgAvail *availPtr, *prevPtr;
1084 Package *pkgPtr;
1085 Tcl_HashEntry *hPtr;
1086 Tcl_HashSearch search;
1087 Tcl_HashTable *tablePtr;
1088 const char *version;
1089 const char *argv2, *argv3, *argv4;
1090 char *iva = NULL, *ivb = NULL;
1091 Tcl_Obj *objvListPtr, **newObjvPtr;
1092
1093 if (objc < 2) {
1094 Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
1095 return TCL_ERROR;
1096 }
1097
1098 if (Tcl_GetIndexFromObj(interp, objv[1], pkgOptions, "option", 0,
1099 &optionIndex) != TCL_OK) {
1100 return TCL_ERROR;
1101 }
1102 switch ((enum pkgOptionsEnum) optionIndex) {
1103 case PKG_FILES: {
1104 PkgFiles *pkgFiles;
1105
1106 if (objc != 3) {
1107 Tcl_WrongNumArgs(interp, 2, objv, "package");
1108 return TCL_ERROR;
1109 }
1110 pkgFiles = (PkgFiles *) Tcl_GetAssocData(interp, "tclPkgFiles", NULL);
1111 if (pkgFiles) {
1112 Tcl_HashEntry *entry =
1113 Tcl_FindHashEntry(&pkgFiles->table, Tcl_GetString(objv[2]));
1114 if (entry) {
1115 Tcl_SetObjResult(interp, (Tcl_Obj *)Tcl_GetHashValue(entry));
1116 }
1117 }
1118 break;
1119 }
1120 case PKG_FORGET: {
1121 const char *keyString;
1122 PkgFiles *pkgFiles = (PkgFiles *)
1123 Tcl_GetAssocData(interp, "tclPkgFiles", NULL);
1124
1125 for (i = 2; i < objc; i++) {
1126 keyString = TclGetString(objv[i]);
1127 if (pkgFiles) {
1128 hPtr = Tcl_FindHashEntry(&pkgFiles->table, keyString);
1129 if (hPtr) {
1130 Tcl_Obj *obj = (Tcl_Obj *)Tcl_GetHashValue(hPtr);
1131 Tcl_DeleteHashEntry(hPtr);
1132 Tcl_DecrRefCount(obj);
1133 }
1134 }
1135
1136 hPtr = Tcl_FindHashEntry(&iPtr->packageTable, keyString);
1137 if (hPtr == NULL) {
1138 continue;
1139 }
1140 pkgPtr = (Package *)Tcl_GetHashValue(hPtr);
1141 Tcl_DeleteHashEntry(hPtr);
1142 if (pkgPtr->version != NULL) {
1143 Tcl_DecrRefCount(pkgPtr->version);
1144 }
1145 while (pkgPtr->availPtr != NULL) {
1146 availPtr = pkgPtr->availPtr;
1147 pkgPtr->availPtr = availPtr->nextPtr;
1148 Tcl_EventuallyFree(availPtr->version, TCL_DYNAMIC);
1149 Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC);
1150 if (availPtr->pkgIndex) {
1151 Tcl_EventuallyFree(availPtr->pkgIndex, TCL_DYNAMIC);
1152 availPtr->pkgIndex = NULL;
1153 }
1154 ckfree(availPtr);
1155 }
1156 ckfree(pkgPtr);
1157 }
1158 break;
1159 }
1160 case PKG_IFNEEDED: {
1161 int length, res;
1162 char *argv3i, *avi;
1163
1164 if ((objc != 4) && (objc != 5)) {
1165 Tcl_WrongNumArgs(interp, 2, objv, "package version ?script?");
1166 return TCL_ERROR;
1167 }
1168 argv3 = TclGetString(objv[3]);
1169 if (CheckVersionAndConvert(interp, argv3, &argv3i, NULL) != TCL_OK) {
1170 return TCL_ERROR;
1171 }
1172 argv2 = TclGetString(objv[2]);
1173 if (objc == 4) {
1174 hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2);
1175 if (hPtr == NULL) {
1176 ckfree(argv3i);
1177 return TCL_OK;
1178 }
1179 pkgPtr = (Package *)Tcl_GetHashValue(hPtr);
1180 } else {
1181 pkgPtr = FindPackage(interp, argv2);
1182 }
1183 argv3 = TclGetStringFromObj(objv[3], &length);
1184
1185 for (availPtr = pkgPtr->availPtr, prevPtr = NULL; availPtr != NULL;
1186 prevPtr = availPtr, availPtr = availPtr->nextPtr) {
1187 if (CheckVersionAndConvert(interp, availPtr->version, &avi,
1188 NULL) != TCL_OK) {
1189 ckfree(argv3i);
1190 return TCL_ERROR;
1191 }
1192
1193 res = CompareVersions(avi, argv3i, NULL);
1194 ckfree(avi);
1195
1196 if (res == 0) {
1197 if (objc == 4) {
1198 ckfree(argv3i);
1199 Tcl_SetObjResult(interp,
1200 Tcl_NewStringObj(availPtr->script, -1));
1201 return TCL_OK;
1202 }
1203 Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC);
1204 if (availPtr->pkgIndex) {
1205 Tcl_EventuallyFree(availPtr->pkgIndex, TCL_DYNAMIC);
1206 availPtr->pkgIndex = NULL;
1207 }
1208 break;
1209 }
1210 }
1211 ckfree(argv3i);
1212
1213 if (objc == 4) {
1214 return TCL_OK;
1215 }
1216 if (availPtr == NULL) {
1217 availPtr = (PkgAvail *)ckalloc(sizeof(PkgAvail));
1218 availPtr->pkgIndex = NULL;
1219 DupBlock(availPtr->version, argv3, length + 1);
1220
1221 if (prevPtr == NULL) {
1222 availPtr->nextPtr = pkgPtr->availPtr;
1223 pkgPtr->availPtr = availPtr;
1224 } else {
1225 availPtr->nextPtr = prevPtr->nextPtr;
1226 prevPtr->nextPtr = availPtr;
1227 }
1228 }
1229 if (iPtr->scriptFile) {
1230 argv4 = TclGetStringFromObj(iPtr->scriptFile, &length);
1231 DupBlock(availPtr->pkgIndex, argv4, length + 1);
1232 }
1233 argv4 = TclGetStringFromObj(objv[4], &length);
1234 DupBlock(availPtr->script, argv4, length + 1);
1235 break;
1236 }
1237 case PKG_NAMES:
1238 if (objc != 2) {
1239 Tcl_WrongNumArgs(interp, 2, objv, NULL);
1240 return TCL_ERROR;
1241 } else {
1242 Tcl_Obj *resultObj;
1243
1244 TclNewObj(resultObj);
1245 tablePtr = &iPtr->packageTable;
1246 for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL;
1247 hPtr = Tcl_NextHashEntry(&search)) {
1248 pkgPtr = (Package *)Tcl_GetHashValue(hPtr);
1249 if ((pkgPtr->version != NULL) || (pkgPtr->availPtr != NULL)) {
1250 Tcl_ListObjAppendElement(NULL,resultObj, Tcl_NewStringObj(
1251 (char *)Tcl_GetHashKey(tablePtr, hPtr), -1));
1252 }
1253 }
1254 Tcl_SetObjResult(interp, resultObj);
1255 }
1256 break;
1257 case PKG_PRESENT: {
1258 const char *name;
1259
1260 if (objc < 3) {
1261 goto require;
1262 }
1263 argv2 = TclGetString(objv[2]);
1264 if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) {
1265 if (objc != 5) {
1266 goto requireSyntax;
1267 }
1268 exact = 1;
1269 name = TclGetString(objv[3]);
1270 } else {
1271 exact = 0;
1272 name = argv2;
1273 }
1274
1275 hPtr = Tcl_FindHashEntry(&iPtr->packageTable, name);
1276 if (hPtr != NULL) {
1277 pkgPtr = (Package *)Tcl_GetHashValue(hPtr);
1278 if (pkgPtr->version != NULL) {
1279 goto require;
1280 }
1281 }
1282
1283 version = NULL;
1284 if (exact) {
1285 version = TclGetString(objv[4]);
1286 if (CheckVersionAndConvert(interp, version, NULL,
1287 NULL) != TCL_OK) {
1288 return TCL_ERROR;
1289 }
1290 } else {
1291 if (CheckAllRequirements(interp, objc-3, objv+3) != TCL_OK) {
1292 return TCL_ERROR;
1293 }
1294 if ((objc > 3) && (CheckVersionAndConvert(interp,
1295 TclGetString(objv[3]), NULL, NULL) == TCL_OK)) {
1296 version = TclGetString(objv[3]);
1297 }
1298 }
1299 Tcl_PkgPresentEx(interp, name, version, exact, NULL);
1300 return TCL_ERROR;
1301 break;
1302 }
1303 case PKG_PROVIDE:
1304 if ((objc != 3) && (objc != 4)) {
1305 Tcl_WrongNumArgs(interp, 2, objv, "package ?version?");
1306 return TCL_ERROR;
1307 }
1308 argv2 = TclGetString(objv[2]);
1309 if (objc == 3) {
1310 hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2);
1311 if (hPtr != NULL) {
1312 pkgPtr = (Package *)Tcl_GetHashValue(hPtr);
1313 if (pkgPtr->version != NULL) {
1314 Tcl_SetObjResult(interp, pkgPtr->version);
1315 }
1316 }
1317 return TCL_OK;
1318 }
1319 argv3 = TclGetString(objv[3]);
1320 if (CheckVersionAndConvert(interp, argv3, NULL, NULL) != TCL_OK) {
1321 return TCL_ERROR;
1322 }
1323 return Tcl_PkgProvideEx(interp, argv2, argv3, NULL);
1324 case PKG_REQUIRE:
1325 require:
1326 if (objc < 3) {
1327 requireSyntax:
1328 Tcl_WrongNumArgs(interp, 2, objv,
1329 "?-exact? package ?requirement ...?");
1330 return TCL_ERROR;
1331 }
1332
1333 version = NULL;
1334
1335 argv2 = TclGetString(objv[2]);
1336 if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) {
1337 Tcl_Obj *ov;
1338
1339 if (objc != 5) {
1340 goto requireSyntax;
1341 }
1342
1343 version = TclGetString(objv[4]);
1344 if (CheckVersionAndConvert(interp, version, NULL,
1345 NULL) != TCL_OK) {
1346 return TCL_ERROR;
1347 }
1348
1349 /*
1350 * Create a new-style requirement for the exact version.
1351 */
1352
1353 ov = Tcl_NewStringObj(version, -1);
1354 Tcl_AppendStringsToObj(ov, "-", version, NULL);
1355 version = NULL;
1356 argv3 = TclGetString(objv[3]);
1357 Tcl_IncrRefCount(objv[3]);
1358
1359 objvListPtr = Tcl_NewListObj(0, NULL);
1360 Tcl_IncrRefCount(objvListPtr);
1361 Tcl_ListObjAppendElement(interp, objvListPtr, ov);
1362 Tcl_ListObjGetElements(interp, objvListPtr, &newobjc, &newObjvPtr);
1363
1364 Tcl_NRAddCallback(interp,
1365 TclNRPackageObjCmdCleanup, objv[3], objvListPtr, NULL,NULL);
1366 Tcl_NRAddCallback(interp,
1367 PkgRequireCore, (void *) argv3, INT2PTR(newobjc),
1368 newObjvPtr, NULL);
1369 return TCL_OK;
1370 } else {
1371 Tcl_Obj *const *newobjv = objv + 3;
1372
1373 newobjc = objc - 3;
1374 if (CheckAllRequirements(interp, objc-3, objv+3) != TCL_OK) {
1375 return TCL_ERROR;
1376 }
1377 objvListPtr = Tcl_NewListObj(0, NULL);
1378 Tcl_IncrRefCount(objvListPtr);
1379 Tcl_IncrRefCount(objv[2]);
1380 for (i = 0; i < newobjc; i++) {
1381 /*
1382 * Tcl_Obj structures may have come from another interpreter,
1383 * so duplicate them.
1384 */
1385
1386 Tcl_ListObjAppendElement(interp, objvListPtr,
1387 Tcl_DuplicateObj(newobjv[i]));
1388 }
1389 Tcl_ListObjGetElements(interp, objvListPtr, &newobjc, &newObjvPtr);
1390 Tcl_NRAddCallback(interp,
1391 TclNRPackageObjCmdCleanup, objv[2], objvListPtr, NULL,NULL);
1392 Tcl_NRAddCallback(interp,
1393 PkgRequireCore, (void *) argv2, INT2PTR(newobjc),
1394 newObjvPtr, NULL);
1395 return TCL_OK;
1396 }
1397 break;
1398 case PKG_UNKNOWN: {
1399 int length;
1400
1401 if (objc == 2) {
1402 if (iPtr->packageUnknown != NULL) {
1403 Tcl_SetObjResult(interp,
1404 Tcl_NewStringObj(iPtr->packageUnknown, -1));
1405 }
1406 } else if (objc == 3) {
1407 if (iPtr->packageUnknown != NULL) {
1408 ckfree(iPtr->packageUnknown);
1409 }
1410 argv2 = TclGetStringFromObj(objv[2], &length);
1411 if (argv2[0] == 0) {
1412 iPtr->packageUnknown = NULL;
1413 } else {
1414 DupBlock(iPtr->packageUnknown, argv2, length+1);
1415 }
1416 } else {
1417 Tcl_WrongNumArgs(interp, 2, objv, "?command?");
1418 return TCL_ERROR;
1419 }
1420 break;
1421 }
1422 case PKG_PREFER: {
1423 static const char *const pkgPreferOptions[] = {
1424 "latest", "stable", NULL
1425 };
1426
1427 /*
1428 * See tclInt.h for the enum, just before Interp.
1429 */
1430
1431 if (objc > 3) {
1432 Tcl_WrongNumArgs(interp, 2, objv, "?latest|stable?");
1433 return TCL_ERROR;
1434 } else if (objc == 3) {
1435 /*
1436 * Seting the value.
1437 */
1438
1439 int newPref;
1440
1441 if (Tcl_GetIndexFromObj(interp, objv[2], pkgPreferOptions,
1442 "preference", 0, &newPref) != TCL_OK) {
1443 return TCL_ERROR;
1444 }
1445
1446 if (newPref < iPtr->packagePrefer) {
1447 iPtr->packagePrefer = newPref;
1448 }
1449 }
1450
1451 /*
1452 * Always return current value.
1453 */
1454
1455 Tcl_SetObjResult(interp,
1456 Tcl_NewStringObj(pkgPreferOptions[iPtr->packagePrefer], -1));
1457 break;
1458 }
1459 case PKG_VCOMPARE:
1460 if (objc != 4) {
1461 Tcl_WrongNumArgs(interp, 2, objv, "version1 version2");
1462 return TCL_ERROR;
1463 }
1464 argv3 = TclGetString(objv[3]);
1465 argv2 = TclGetString(objv[2]);
1466 if (CheckVersionAndConvert(interp, argv2, &iva, NULL) != TCL_OK ||
1467 CheckVersionAndConvert(interp, argv3, &ivb, NULL) != TCL_OK) {
1468 if (iva != NULL) {
1469 ckfree(iva);
1470 }
1471
1472 /*
1473 * ivb cannot be set in this branch.
1474 */
1475
1476 return TCL_ERROR;
1477 }
1478
1479 /*
1480 * Comparison is done on the internal representation.
1481 */
1482
1483 Tcl_SetObjResult(interp,
1484 Tcl_NewWideIntObj(CompareVersions(iva, ivb, NULL)));
1485 ckfree(iva);
1486 ckfree(ivb);
1487 break;
1488 case PKG_VERSIONS:
1489 if (objc != 3) {
1490 Tcl_WrongNumArgs(interp, 2, objv, "package");
1491 return TCL_ERROR;
1492 } else {
1493 Tcl_Obj *resultObj;
1494
1495 TclNewObj(resultObj);
1496 argv2 = TclGetString(objv[2]);
1497 hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2);
1498 if (hPtr != NULL) {
1499 pkgPtr = (Package *)Tcl_GetHashValue(hPtr);
1500 for (availPtr = pkgPtr->availPtr; availPtr != NULL;
1501 availPtr = availPtr->nextPtr) {
1502 Tcl_ListObjAppendElement(NULL, resultObj,
1503 Tcl_NewStringObj(availPtr->version, -1));
1504 }
1505 }
1506 Tcl_SetObjResult(interp, resultObj);
1507 }
1508 break;
1509 case PKG_VSATISFIES: {
1510 char *argv2i = NULL;
1511
1512 if (objc < 4) {
1513 Tcl_WrongNumArgs(interp, 2, objv, "version ?requirement ...?");
1514 return TCL_ERROR;
1515 }
1516
1517 argv2 = TclGetString(objv[2]);
1518 if (CheckVersionAndConvert(interp, argv2, &argv2i, NULL) != TCL_OK) {
1519 return TCL_ERROR;
1520 } else if (CheckAllRequirements(interp, objc-3, objv+3) != TCL_OK) {
1521 ckfree(argv2i);
1522 return TCL_ERROR;
1523 }
1524
1525 satisfies = SomeRequirementSatisfied(argv2i, objc-3, objv+3);
1526 ckfree(argv2i);
1527
1528 Tcl_SetObjResult(interp, Tcl_NewBooleanObj(satisfies));
1529 break;
1530 }
1531 default:
1532 Tcl_Panic("Tcl_PackageObjCmd: bad option index to pkgOptions");
1533 }
1534 return TCL_OK;
1535 }
1536
1537 static int
TclNRPackageObjCmdCleanup(ClientData data[],TCL_UNUSED (Tcl_Interp *),int result)1538 TclNRPackageObjCmdCleanup(
1539 ClientData data[],
1540 TCL_UNUSED(Tcl_Interp *),
1541 int result)
1542 {
1543 TclDecrRefCount((Tcl_Obj *) data[0]);
1544 TclDecrRefCount((Tcl_Obj *) data[1]);
1545 return result;
1546 }
1547
1548 /*
1549 *----------------------------------------------------------------------
1550 *
1551 * FindPackage --
1552 *
1553 * This function finds the Package record for a particular package in a
1554 * particular interpreter, creating a record if one doesn't already
1555 * exist.
1556 *
1557 * Results:
1558 * The return value is a pointer to the Package record for the package.
1559 *
1560 * Side effects:
1561 * A new Package record may be created.
1562 *
1563 *----------------------------------------------------------------------
1564 */
1565
1566 static Package *
FindPackage(Tcl_Interp * interp,const char * name)1567 FindPackage(
1568 Tcl_Interp *interp, /* Interpreter to use for package lookup. */
1569 const char *name) /* Name of package to fine. */
1570 {
1571 Interp *iPtr = (Interp *) interp;
1572 Tcl_HashEntry *hPtr;
1573 int isNew;
1574 Package *pkgPtr;
1575
1576 hPtr = Tcl_CreateHashEntry(&iPtr->packageTable, name, &isNew);
1577 if (isNew) {
1578 pkgPtr = (Package *)ckalloc(sizeof(Package));
1579 pkgPtr->version = NULL;
1580 pkgPtr->availPtr = NULL;
1581 pkgPtr->clientData = NULL;
1582 Tcl_SetHashValue(hPtr, pkgPtr);
1583 } else {
1584 pkgPtr = (Package *)Tcl_GetHashValue(hPtr);
1585 }
1586 return pkgPtr;
1587 }
1588
1589 /*
1590 *----------------------------------------------------------------------
1591 *
1592 * TclFreePackageInfo --
1593 *
1594 * This function is called during interpreter deletion to free all of the
1595 * package-related information for the interpreter.
1596 *
1597 * Results:
1598 * None.
1599 *
1600 * Side effects:
1601 * Memory is freed.
1602 *
1603 *----------------------------------------------------------------------
1604 */
1605
1606 void
TclFreePackageInfo(Interp * iPtr)1607 TclFreePackageInfo(
1608 Interp *iPtr) /* Interpreter that is being deleted. */
1609 {
1610 Package *pkgPtr;
1611 Tcl_HashSearch search;
1612 Tcl_HashEntry *hPtr;
1613 PkgAvail *availPtr;
1614
1615 for (hPtr = Tcl_FirstHashEntry(&iPtr->packageTable, &search);
1616 hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
1617 pkgPtr = (Package *)Tcl_GetHashValue(hPtr);
1618 if (pkgPtr->version != NULL) {
1619 Tcl_DecrRefCount(pkgPtr->version);
1620 }
1621 while (pkgPtr->availPtr != NULL) {
1622 availPtr = pkgPtr->availPtr;
1623 pkgPtr->availPtr = availPtr->nextPtr;
1624 Tcl_EventuallyFree(availPtr->version, TCL_DYNAMIC);
1625 Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC);
1626 if (availPtr->pkgIndex) {
1627 Tcl_EventuallyFree(availPtr->pkgIndex, TCL_DYNAMIC);
1628 availPtr->pkgIndex = NULL;
1629 }
1630 ckfree(availPtr);
1631 }
1632 ckfree(pkgPtr);
1633 }
1634 Tcl_DeleteHashTable(&iPtr->packageTable);
1635 if (iPtr->packageUnknown != NULL) {
1636 ckfree(iPtr->packageUnknown);
1637 }
1638 }
1639
1640 /*
1641 *----------------------------------------------------------------------
1642 *
1643 * CheckVersionAndConvert --
1644 *
1645 * This function checks to see whether a version number has valid syntax.
1646 * It also generates a semi-internal representation (string rep of a list
1647 * of numbers).
1648 *
1649 * Results:
1650 * If string is a properly formed version number the TCL_OK is returned.
1651 * Otherwise TCL_ERROR is returned and an error message is left in the
1652 * interp's result.
1653 *
1654 * Side effects:
1655 * None.
1656 *
1657 *----------------------------------------------------------------------
1658 */
1659
1660 static int
CheckVersionAndConvert(Tcl_Interp * interp,const char * string,char ** internal,int * stable)1661 CheckVersionAndConvert(
1662 Tcl_Interp *interp, /* Used for error reporting. */
1663 const char *string, /* Supposedly a version number, which is
1664 * groups of decimal digits separated by
1665 * dots. */
1666 char **internal, /* Internal normalized representation */
1667 int *stable) /* Flag: Version is (un)stable. */
1668 {
1669 const char *p = string;
1670 char prevChar;
1671 int hasunstable = 0;
1672 /*
1673 * 4* assuming that each char is a separator (a,b become ' -x ').
1674 * 4+ to have spce for an additional -2 at the end
1675 */
1676 char *ibuf = (char *)ckalloc(4 + 4*strlen(string));
1677 char *ip = ibuf;
1678
1679 /*
1680 * Basic rules
1681 * (1) First character has to be a digit.
1682 * (2) All other characters have to be a digit or '.'
1683 * (3) Two '.'s may not follow each other.
1684 *
1685 * TIP 268, Modified rules
1686 * (1) s.a.
1687 * (2) All other characters have to be a digit, 'a', 'b', or '.'
1688 * (3) s.a.
1689 * (4) Only one of 'a' or 'b' may occur.
1690 * (5) Neither 'a', nor 'b' may occur before or after a '.'
1691 */
1692
1693 if (!isdigit(UCHAR(*p))) { /* INTL: digit */
1694 goto error;
1695 }
1696
1697 *ip++ = *p;
1698
1699 for (prevChar = *p, p++; *p != 0; p++) {
1700 if (!isdigit(UCHAR(*p)) && /* INTL: digit */
1701 ((*p!='.' && *p!='a' && *p!='b') ||
1702 ((hasunstable && (*p=='a' || *p=='b')) ||
1703 ((prevChar=='a' || prevChar=='b' || prevChar=='.')
1704 && (*p=='.')) ||
1705 ((*p=='a' || *p=='b' || *p=='.') && prevChar=='.')))) {
1706 goto error;
1707 }
1708
1709 if (*p == 'a' || *p == 'b') {
1710 hasunstable = 1;
1711 }
1712
1713 /*
1714 * Translation to the internal rep. Regular version chars are copied
1715 * as is. The separators are translated to numerics. The new separator
1716 * for all parts is space.
1717 */
1718
1719 if (*p == '.') {
1720 *ip++ = ' ';
1721 *ip++ = '0';
1722 *ip++ = ' ';
1723 } else if (*p == 'a') {
1724 *ip++ = ' ';
1725 *ip++ = '-';
1726 *ip++ = '2';
1727 *ip++ = ' ';
1728 } else if (*p == 'b') {
1729 *ip++ = ' ';
1730 *ip++ = '-';
1731 *ip++ = '1';
1732 *ip++ = ' ';
1733 } else {
1734 *ip++ = *p;
1735 }
1736
1737 prevChar = *p;
1738 }
1739 if (prevChar!='.' && prevChar!='a' && prevChar!='b') {
1740 *ip = '\0';
1741 if (internal != NULL) {
1742 *internal = ibuf;
1743 } else {
1744 ckfree(ibuf);
1745 }
1746 if (stable != NULL) {
1747 *stable = !hasunstable;
1748 }
1749 return TCL_OK;
1750 }
1751
1752 error:
1753 ckfree(ibuf);
1754 Tcl_SetObjResult(interp, Tcl_ObjPrintf(
1755 "expected version number but got \"%s\"", string));
1756 Tcl_SetErrorCode(interp, "TCL", "VALUE", "VERSION", NULL);
1757 return TCL_ERROR;
1758 }
1759
1760 /*
1761 *----------------------------------------------------------------------
1762 *
1763 * CompareVersions --
1764 *
1765 * This function compares two version numbers (in internal rep).
1766 *
1767 * Results:
1768 * The return value is -1 if v1 is less than v2, 0 if the two version
1769 * numbers are the same, and 1 if v1 is greater than v2. If *satPtr is
1770 * non-NULL, the word it points to is filled in with 1 if v2 >= v1 and
1771 * both numbers have the same major number or 0 otherwise.
1772 *
1773 * Side effects:
1774 * None.
1775 *
1776 *----------------------------------------------------------------------
1777 */
1778
1779 static int
CompareVersions(char * v1,char * v2,int * isMajorPtr)1780 CompareVersions(
1781 char *v1, char *v2, /* Versions strings, of form 2.1.3 (any number
1782 * of version numbers). */
1783 int *isMajorPtr) /* If non-null, the word pointed to is filled
1784 * in with a 0/1 value. 1 means that the
1785 * difference occured in the first element. */
1786 {
1787 int thisIsMajor, res, flip;
1788 char *s1, *e1, *s2, *e2, o1, o2;
1789
1790 /*
1791 * Each iteration of the following loop processes one number from each
1792 * string, terminated by a " " (space). If those numbers don't match then
1793 * the comparison is over; otherwise, we loop back for the next number.
1794 *
1795 * TIP 268.
1796 * This is identical the function 'ComparePkgVersion', but using the new
1797 * space separator as used by the internal rep of version numbers. The
1798 * special separators 'a' and 'b' have already been dealt with in
1799 * 'CheckVersionAndConvert', they were translated into numbers as well.
1800 * This keeps the comparison sane. Otherwise we would have to compare
1801 * numerics, the separators, and also deal with the special case of
1802 * end-of-string compared to separators. The semi-list rep we get here is
1803 * much easier to handle, as it is still regular.
1804 *
1805 * Rewritten to not compute a numeric value for the extracted version
1806 * number, but do string comparison. Skip any leading zeros for that to
1807 * work. This change breaks through the 32bit-limit on version numbers.
1808 */
1809
1810 thisIsMajor = 1;
1811 s1 = v1;
1812 s2 = v2;
1813
1814 while (1) {
1815 /*
1816 * Parse one decimal number from the front of each string. Skip
1817 * leading zeros. Terminate found number for upcoming string-wise
1818 * comparison, if needed.
1819 */
1820
1821 while ((*s1 != 0) && (*s1 == '0')) {
1822 s1++;
1823 }
1824 while ((*s2 != 0) && (*s2 == '0')) {
1825 s2++;
1826 }
1827
1828 /*
1829 * s1, s2 now point to the beginnings of the numbers to compare. Test
1830 * for their signs first, as shortcut to the result (different signs),
1831 * or determines if result has to be flipped (both negative). If there
1832 * is no shortcut we have to insert terminators later to limit the
1833 * strcmp.
1834 */
1835
1836 if ((*s1 == '-') && (*s2 != '-')) {
1837 /* s1 < 0, s2 >= 0 => s1 < s2 */
1838 res = -1;
1839 break;
1840 }
1841 if ((*s1 != '-') && (*s2 == '-')) {
1842 /* s1 >= 0, s2 < 0 => s1 > s2 */
1843 res = 1;
1844 break;
1845 }
1846
1847 if ((*s1 == '-') && (*s2 == '-')) {
1848 /* a < b => -a > -b, etc. */
1849 s1++;
1850 s2++;
1851 flip = 1;
1852 } else {
1853 flip = 0;
1854 }
1855
1856 /*
1857 * The string comparison is needed, so now we determine where the
1858 * numbers end.
1859 */
1860
1861 e1 = s1;
1862 while ((*e1 != 0) && (*e1 != ' ')) {
1863 e1++;
1864 }
1865 e2 = s2;
1866 while ((*e2 != 0) && (*e2 != ' ')) {
1867 e2++;
1868 }
1869
1870 /*
1871 * s1 .. e1 and s2 .. e2 now bracket the numbers to compare. Insert
1872 * terminators, compare, and restore actual contents. First however
1873 * another shortcut. Compare lengths. Shorter string is smaller
1874 * number! Thus we strcmp only strings of identical length.
1875 */
1876
1877 if ((e1-s1) < (e2-s2)) {
1878 res = -1;
1879 } else if ((e2-s2) < (e1-s1)) {
1880 res = 1;
1881 } else {
1882 o1 = *e1;
1883 *e1 = '\0';
1884 o2 = *e2;
1885 *e2 = '\0';
1886
1887 res = strcmp(s1, s2);
1888 res = (res < 0) ? -1 : (res ? 1 : 0);
1889
1890 *e1 = o1;
1891 *e2 = o2;
1892 }
1893
1894 /*
1895 * Stop comparing segments when a difference has been found. Here we
1896 * may have to flip the result to account for signs.
1897 */
1898
1899 if (res != 0) {
1900 if (flip) {
1901 res = -res;
1902 }
1903 break;
1904 }
1905
1906 /*
1907 * Go on to the next version number if the current numbers match.
1908 * However stop processing if the end of both numbers has been
1909 * reached.
1910 */
1911
1912 s1 = e1;
1913 s2 = e2;
1914
1915 if (*s1 != 0) {
1916 s1++;
1917 } else if (*s2 == 0) {
1918 /*
1919 * s1, s2 both at the end => identical
1920 */
1921
1922 res = 0;
1923 break;
1924 }
1925 if (*s2 != 0) {
1926 s2++;
1927 }
1928 thisIsMajor = 0;
1929 }
1930
1931 if (isMajorPtr != NULL) {
1932 *isMajorPtr = thisIsMajor;
1933 }
1934
1935 return res;
1936 }
1937
1938 /*
1939 *----------------------------------------------------------------------
1940 *
1941 * CheckAllRequirements --
1942 *
1943 * This function checks to see whether all requirements in a set have
1944 * valid syntax.
1945 *
1946 * Results:
1947 * TCL_OK is returned if all requirements are valid. Otherwise TCL_ERROR
1948 * is returned and an error message is left in the interp's result.
1949 *
1950 * Side effects:
1951 * May modify the interpreter result.
1952 *
1953 *----------------------------------------------------------------------
1954 */
1955
1956 static int
CheckAllRequirements(Tcl_Interp * interp,int reqc,Tcl_Obj * const reqv[])1957 CheckAllRequirements(
1958 Tcl_Interp *interp,
1959 int reqc, /* Requirements to check. */
1960 Tcl_Obj *const reqv[])
1961 {
1962 int i;
1963
1964 for (i = 0; i < reqc; i++) {
1965 if ((CheckRequirement(interp, TclGetString(reqv[i])) != TCL_OK)) {
1966 return TCL_ERROR;
1967 }
1968 }
1969 return TCL_OK;
1970 }
1971
1972 /*
1973 *----------------------------------------------------------------------
1974 *
1975 * CheckRequirement --
1976 *
1977 * This function checks to see whether a requirement has valid syntax.
1978 *
1979 * Results:
1980 * If string is a properly formed requirement then TCL_OK is returned.
1981 * Otherwise TCL_ERROR is returned and an error message is left in the
1982 * interp's result.
1983 *
1984 * Side effects:
1985 * None.
1986 *
1987 *----------------------------------------------------------------------
1988 */
1989
1990 static int
CheckRequirement(Tcl_Interp * interp,const char * string)1991 CheckRequirement(
1992 Tcl_Interp *interp, /* Used for error reporting. */
1993 const char *string) /* Supposedly a requirement. */
1994 {
1995 /*
1996 * Syntax of requirement = version
1997 * = version-version
1998 * = version-
1999 */
2000
2001 char *dash = NULL, *buf;
2002
2003 dash = (char *)strchr(string, '-');
2004 if (dash == NULL) {
2005 /*
2006 * No dash found, has to be a simple version.
2007 */
2008
2009 return CheckVersionAndConvert(interp, string, NULL, NULL);
2010 }
2011
2012 if (strchr(dash+1, '-') != NULL) {
2013 /*
2014 * More dashes found after the first. This is wrong.
2015 */
2016
2017 Tcl_SetObjResult(interp, Tcl_ObjPrintf(
2018 "expected versionMin-versionMax but got \"%s\"", string));
2019 Tcl_SetErrorCode(interp, "TCL", "VALUE", "VERSIONRANGE", NULL);
2020 return TCL_ERROR;
2021 }
2022
2023 /*
2024 * Exactly one dash is present. Copy the string, split at the location of
2025 * dash and check that both parts are versions. Note that the max part can
2026 * be empty. Also note that the string allocated with strdup() must be
2027 * freed with free() and not ckfree().
2028 */
2029
2030 DupString(buf, string);
2031 dash = buf + (dash - string);
2032 *dash = '\0'; /* buf now <=> min part */
2033 dash++; /* dash now <=> max part */
2034
2035 if ((CheckVersionAndConvert(interp, buf, NULL, NULL) != TCL_OK) ||
2036 ((*dash != '\0') &&
2037 (CheckVersionAndConvert(interp, dash, NULL, NULL) != TCL_OK))) {
2038 ckfree(buf);
2039 return TCL_ERROR;
2040 }
2041
2042 ckfree(buf);
2043 return TCL_OK;
2044 }
2045
2046 /*
2047 *----------------------------------------------------------------------
2048 *
2049 * AddRequirementsToResult --
2050 *
2051 * This function accumulates requirements in the interpreter result.
2052 *
2053 * Results:
2054 * None.
2055 *
2056 * Side effects:
2057 * The interpreter result is extended.
2058 *
2059 *----------------------------------------------------------------------
2060 */
2061
2062 static void
AddRequirementsToResult(Tcl_Interp * interp,int reqc,Tcl_Obj * const reqv[])2063 AddRequirementsToResult(
2064 Tcl_Interp *interp,
2065 int reqc, /* Requirements constraining the desired
2066 * version. */
2067 Tcl_Obj *const reqv[]) /* 0 means to use the latest version
2068 * available. */
2069 {
2070 Tcl_Obj *result = Tcl_GetObjResult(interp);
2071 int i, length;
2072
2073 for (i = 0; i < reqc; i++) {
2074 const char *v = TclGetStringFromObj(reqv[i], &length);
2075
2076 if ((length & 0x1) && (v[length/2] == '-')
2077 && (strncmp(v, v+((length+1)/2), length/2) == 0)) {
2078 Tcl_AppendPrintfToObj(result, " exactly %s", v+((length+1)/2));
2079 } else {
2080 Tcl_AppendPrintfToObj(result, " %s", v);
2081 }
2082 }
2083 }
2084
2085 /*
2086 *----------------------------------------------------------------------
2087 *
2088 * AddRequirementsToDString --
2089 *
2090 * This function accumulates requirements in a DString.
2091 *
2092 * Results:
2093 * None.
2094 *
2095 * Side effects:
2096 * The DString argument is extended.
2097 *
2098 *----------------------------------------------------------------------
2099 */
2100
2101 static void
AddRequirementsToDString(Tcl_DString * dsPtr,int reqc,Tcl_Obj * const reqv[])2102 AddRequirementsToDString(
2103 Tcl_DString *dsPtr,
2104 int reqc, /* Requirements constraining the desired
2105 * version. */
2106 Tcl_Obj *const reqv[]) /* 0 means to use the latest version
2107 * available. */
2108 {
2109 int i;
2110
2111 if (reqc > 0) {
2112 for (i = 0; i < reqc; i++) {
2113 TclDStringAppendLiteral(dsPtr, " ");
2114 TclDStringAppendObj(dsPtr, reqv[i]);
2115 }
2116 } else {
2117 TclDStringAppendLiteral(dsPtr, " 0-");
2118 }
2119 }
2120
2121 /*
2122 *----------------------------------------------------------------------
2123 *
2124 * SomeRequirementSatisfied --
2125 *
2126 * This function checks to see whether a version satisfies at least one
2127 * of a set of requirements.
2128 *
2129 * Results:
2130 * If the requirements are satisfied 1 is returned. Otherwise 0 is
2131 * returned. The function assumes that all pieces have valid syntax. And
2132 * is allowed to make that assumption.
2133 *
2134 * Side effects:
2135 * None.
2136 *
2137 *----------------------------------------------------------------------
2138 */
2139
2140 static int
SomeRequirementSatisfied(char * availVersionI,int reqc,Tcl_Obj * const reqv[])2141 SomeRequirementSatisfied(
2142 char *availVersionI, /* Candidate version to check against the
2143 * requirements. */
2144 int reqc, /* Requirements constraining the desired
2145 * version. */
2146 Tcl_Obj *const reqv[]) /* 0 means to use the latest version
2147 * available. */
2148 {
2149 int i;
2150
2151 for (i = 0; i < reqc; i++) {
2152 if (RequirementSatisfied(availVersionI, TclGetString(reqv[i]))) {
2153 return 1;
2154 }
2155 }
2156 return 0;
2157 }
2158
2159 /*
2160 *----------------------------------------------------------------------
2161 *
2162 * RequirementSatisfied --
2163 *
2164 * This function checks to see whether a version satisfies a requirement.
2165 *
2166 * Results:
2167 * If the requirement is satisfied 1 is returned. Otherwise 0 is
2168 * returned. The function assumes that all pieces have valid syntax, and
2169 * is allowed to make that assumption.
2170 *
2171 * Side effects:
2172 * None.
2173 *
2174 *----------------------------------------------------------------------
2175 */
2176
2177 static int
RequirementSatisfied(char * havei,const char * req)2178 RequirementSatisfied(
2179 char *havei, /* Version string, of candidate package we
2180 * have. */
2181 const char *req) /* Requirement string the candidate has to
2182 * satisfy. */
2183 {
2184 /*
2185 * The have candidate is already in internal rep.
2186 */
2187
2188 int satisfied, res;
2189 char *dash = NULL, *buf, *min, *max;
2190
2191 dash = (char *)strchr(req, '-');
2192 if (dash == NULL) {
2193 /*
2194 * No dash found, is a simple version, fallback to regular check. The
2195 * 'CheckVersionAndConvert' cannot fail. We pad the requirement with
2196 * 'a0', i.e '-2' before doing the comparison to properly accept
2197 * unstables as well.
2198 */
2199
2200 char *reqi = NULL;
2201 int thisIsMajor;
2202
2203 CheckVersionAndConvert(NULL, req, &reqi, NULL);
2204 strcat(reqi, " -2");
2205 res = CompareVersions(havei, reqi, &thisIsMajor);
2206 satisfied = (res == 0) || ((res == 1) && !thisIsMajor);
2207 ckfree(reqi);
2208 return satisfied;
2209 }
2210
2211 /*
2212 * Exactly one dash is present (Assumption of valid syntax). Copy the req,
2213 * split at the location of dash and check that both parts are versions.
2214 * Note that the max part can be empty.
2215 */
2216
2217 DupString(buf, req);
2218 dash = buf + (dash - req);
2219 *dash = '\0'; /* buf now <=> min part */
2220 dash++; /* dash now <=> max part */
2221
2222 if (*dash == '\0') {
2223 /*
2224 * We have a min, but no max. For the comparison we generate the
2225 * internal rep, padded with 'a0' i.e. '-2'.
2226 */
2227
2228 CheckVersionAndConvert(NULL, buf, &min, NULL);
2229 strcat(min, " -2");
2230 satisfied = (CompareVersions(havei, min, NULL) >= 0);
2231 ckfree(min);
2232 ckfree(buf);
2233 return satisfied;
2234 }
2235
2236 /*
2237 * We have both min and max, and generate their internal reps. When
2238 * identical we compare as is, otherwise we pad with 'a0' to ove the range
2239 * a bit.
2240 */
2241
2242 CheckVersionAndConvert(NULL, buf, &min, NULL);
2243 CheckVersionAndConvert(NULL, dash, &max, NULL);
2244
2245 if (CompareVersions(min, max, NULL) == 0) {
2246 satisfied = (CompareVersions(min, havei, NULL) == 0);
2247 } else {
2248 strcat(min, " -2");
2249 strcat(max, " -2");
2250 satisfied = ((CompareVersions(min, havei, NULL) <= 0) &&
2251 (CompareVersions(havei, max, NULL) < 0));
2252 }
2253
2254 ckfree(min);
2255 ckfree(max);
2256 ckfree(buf);
2257 return satisfied;
2258 }
2259
2260 /*
2261 *----------------------------------------------------------------------
2262 *
2263 * Tcl_PkgInitStubsCheck --
2264 *
2265 * This is a replacement routine for Tcl_InitStubs() that is called
2266 * from code where -DUSE_TCL_STUBS has not been enabled.
2267 *
2268 * Results:
2269 * Returns the version of a conforming stubs table, or NULL, if
2270 * the table version doesn't satisfy the requested requirements,
2271 * according to historical practice.
2272 *
2273 * Side effects:
2274 * None.
2275 *
2276 *----------------------------------------------------------------------
2277 */
2278
2279 const char *
Tcl_PkgInitStubsCheck(Tcl_Interp * interp,const char * version,int exact)2280 Tcl_PkgInitStubsCheck(
2281 Tcl_Interp *interp,
2282 const char * version,
2283 int exact)
2284 {
2285 const char *actualVersion = Tcl_PkgPresent(interp, "Tcl", version, 0);
2286
2287 if ((exact&1) && actualVersion) {
2288 const char *p = version;
2289 int count = 0;
2290
2291 while (*p) {
2292 count += !isdigit(UCHAR(*p++));
2293 }
2294 if (count == 1) {
2295 if (0 != strncmp(version, actualVersion, strlen(version))) {
2296 /* Construct error message */
2297 Tcl_PkgPresent(interp, "Tcl", version, 1);
2298 return NULL;
2299 }
2300 } else {
2301 return Tcl_PkgPresent(interp, "Tcl", version, 1);
2302 }
2303 }
2304 return actualVersion;
2305 }
2306 /*
2307 * Local Variables:
2308 * mode: c
2309 * c-basic-offset: 4
2310 * fill-column: 78
2311 * End:
2312 */
2313