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