/[dtapublic]/projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclpkg.c
ViewVC logotype

Contents of /projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclpkg.c

Parent Directory Parent Directory | Revision Log Revision Log


Revision 64 - (show annotations) (download)
Sun Oct 30 04:21:11 2016 UTC (7 years, 11 months ago) by dashley
File MIME type: text/plain
File size: 29593 byte(s)
Adjust line endings to Windows style.
Set properties to expand the "Header" keyword.
Change header and footer.
1 /*$Header$ */
2 /*
3 * tclPkg.c --
4 *
5 * This file implements package and version control for Tcl via
6 * the "package" command and a few C APIs.
7 *
8 * Copyright (c) 1996 Sun Microsystems, Inc.
9 *
10 * See the file "license.terms" for information on usage and redistribution
11 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
12 *
13 * RCS: @(#) $Id: tclpkg.c,v 1.1.1.1 2001/06/13 04:45:00 dtashley Exp $
14 */
15
16 #include "tclInt.h"
17
18 /*
19 * Each invocation of the "package ifneeded" command creates a structure
20 * of the following type, which is used to load the package into the
21 * interpreter if it is requested with a "package require" command.
22 */
23
24 typedef struct PkgAvail {
25 char *version; /* Version string; malloc'ed. */
26 char *script; /* Script to invoke to provide this version
27 * of the package. Malloc'ed and protected
28 * by Tcl_Preserve and Tcl_Release. */
29 struct PkgAvail *nextPtr; /* Next in list of available versions of
30 * the same package. */
31 } PkgAvail;
32
33 /*
34 * For each package that is known in any way to an interpreter, there
35 * is one record of the following type. These records are stored in
36 * the "packageTable" hash table in the interpreter, keyed by
37 * package name such as "Tk" (no version number).
38 */
39
40 typedef struct Package {
41 char *version; /* Version that has been supplied in this
42 * interpreter via "package provide"
43 * (malloc'ed). NULL means the package doesn't
44 * exist in this interpreter yet. */
45 PkgAvail *availPtr; /* First in list of all available versions
46 * of this package. */
47 ClientData clientData; /* Client data. */
48 } Package;
49
50 /*
51 * Prototypes for procedures defined in this file:
52 */
53
54 static int CheckVersion _ANSI_ARGS_((Tcl_Interp *interp,
55 char *string));
56 static int ComparePkgVersions _ANSI_ARGS_((char *v1, char *v2,
57 int *satPtr));
58 static Package * FindPackage _ANSI_ARGS_((Tcl_Interp *interp,
59 char *name));
60
61 /*
62 *----------------------------------------------------------------------
63 *
64 * Tcl_PkgProvide / Tcl_PkgProvideEx --
65 *
66 * This procedure is invoked to declare that a particular version
67 * of a particular package is now present in an interpreter. There
68 * must not be any other version of this package already
69 * provided in the interpreter.
70 *
71 * Results:
72 * Normally returns TCL_OK; if there is already another version
73 * of the package loaded then TCL_ERROR is returned and an error
74 * message is left in the interp's result.
75 *
76 * Side effects:
77 * The interpreter remembers that this package is available,
78 * so that no other version of the package may be provided for
79 * the interpreter.
80 *
81 *----------------------------------------------------------------------
82 */
83
84 int
85 Tcl_PkgProvide(interp, name, version)
86 Tcl_Interp *interp; /* Interpreter in which package is now
87 * available. */
88 char *name; /* Name of package. */
89 char *version; /* Version string for package. */
90 {
91 return Tcl_PkgProvideEx(interp, name, version, (ClientData) NULL);
92 }
93
94 int
95 Tcl_PkgProvideEx(interp, name, version, clientData)
96 Tcl_Interp *interp; /* Interpreter in which package is now
97 * available. */
98 char *name; /* Name of package. */
99 char *version; /* Version string for package. */
100 ClientData clientData; /* clientdata for this package (normally
101 * used for C callback function table) */
102 {
103 Package *pkgPtr;
104
105 pkgPtr = FindPackage(interp, name);
106 if (pkgPtr->version == NULL) {
107 pkgPtr->version = ckalloc((unsigned) (strlen(version) + 1));
108 strcpy(pkgPtr->version, version);
109 pkgPtr->clientData = clientData;
110 return TCL_OK;
111 }
112 if (ComparePkgVersions(pkgPtr->version, version, (int *) NULL) == 0) {
113 if (clientData != NULL) {
114 pkgPtr->clientData = clientData;
115 }
116 return TCL_OK;
117 }
118 Tcl_AppendResult(interp, "conflicting versions provided for package \"",
119 name, "\": ", pkgPtr->version, ", then ", version, (char *) NULL);
120 return TCL_ERROR;
121 }
122
123 /*
124 *----------------------------------------------------------------------
125 *
126 * Tcl_PkgRequire / Tcl_PkgRequireEx --
127 *
128 * This procedure is called by code that depends on a particular
129 * version of a particular package. If the package is not already
130 * provided in the interpreter, this procedure invokes a Tcl script
131 * to provide it. If the package is already provided, this
132 * procedure makes sure that the caller's needs don't conflict with
133 * the version that is present.
134 *
135 * Results:
136 * If successful, returns the version string for the currently
137 * provided version of the package, which may be different from
138 * the "version" argument. If the caller's requirements
139 * cannot be met (e.g. the version requested conflicts with
140 * a currently provided version, or the required version cannot
141 * be found, or the script to provide the required version
142 * generates an error), NULL is returned and an error
143 * message is left in the interp's result.
144 *
145 * Side effects:
146 * The script from some previous "package ifneeded" command may
147 * be invoked to provide the package.
148 *
149 *----------------------------------------------------------------------
150 */
151
152 char *
153 Tcl_PkgRequire(interp, name, version, exact)
154 Tcl_Interp *interp; /* Interpreter in which package is now
155 * available. */
156 char *name; /* Name of desired package. */
157 char *version; /* Version string for desired version;
158 * NULL means use the latest version
159 * available. */
160 int exact; /* Non-zero means that only the particular
161 * version given is acceptable. Zero means
162 * use the latest compatible version. */
163 {
164 return Tcl_PkgRequireEx(interp, name, version, exact, (ClientData *) NULL);
165 }
166
167 char *
168 Tcl_PkgRequireEx(interp, name, version, exact, clientDataPtr)
169 Tcl_Interp *interp; /* Interpreter in which package is now
170 * available. */
171 char *name; /* Name of desired package. */
172 char *version; /* Version string for desired version;
173 * NULL means use the latest version
174 * available. */
175 int exact; /* Non-zero means that only the particular
176 * version given is acceptable. Zero means
177 * use the latest compatible version. */
178 ClientData *clientDataPtr; /* Used to return the client data for this
179 * package. If it is NULL then the client
180 * data is not returned. This is unchanged
181 * if this call fails for any reason. */
182 {
183 Package *pkgPtr;
184 PkgAvail *availPtr, *bestPtr;
185 char *script;
186 int code, satisfies, result, pass;
187 Tcl_DString command;
188
189 /*
190 * If an attempt is being made to load this into a standalong executable
191 * on a platform where backlinking is not supported then this must be
192 * a shared version of Tcl (Otherwise the load would have failed).
193 * Detect this situation by checking that this library has been correctly
194 * initialised. If it has not been then return immediately as nothing will
195 * work.
196 */
197
198 if (!tclEmptyStringRep) {
199 Tcl_AppendResult(interp, "Cannot load package \"", name,
200 "\" in standalone executable: This package is not ",
201 "compiled with stub support", NULL);
202 return NULL;
203 }
204
205 /*
206 * It can take up to three passes to find the package: one pass to
207 * run the "package unknown" script, one to run the "package ifneeded"
208 * script for a specific version, and a final pass to lookup the
209 * package loaded by the "package ifneeded" script.
210 */
211
212 for (pass = 1; ; pass++) {
213 pkgPtr = FindPackage(interp, name);
214 if (pkgPtr->version != NULL) {
215 break;
216 }
217
218 /*
219 * The package isn't yet present. Search the list of available
220 * versions and invoke the script for the best available version.
221 */
222
223 bestPtr = NULL;
224 for (availPtr = pkgPtr->availPtr; availPtr != NULL;
225 availPtr = availPtr->nextPtr) {
226 if ((bestPtr != NULL) && (ComparePkgVersions(availPtr->version,
227 bestPtr->version, (int *) NULL) <= 0)) {
228 continue;
229 }
230 if (version != NULL) {
231 result = ComparePkgVersions(availPtr->version, version,
232 &satisfies);
233 if ((result != 0) && exact) {
234 continue;
235 }
236 if (!satisfies) {
237 continue;
238 }
239 }
240 bestPtr = availPtr;
241 }
242 if (bestPtr != NULL) {
243 /*
244 * We found an ifneeded script for the package. Be careful while
245 * executing it: this could cause reentrancy, so (a) protect the
246 * script itself from deletion and (b) don't assume that bestPtr
247 * will still exist when the script completes.
248 */
249
250 script = bestPtr->script;
251 Tcl_Preserve((ClientData) script);
252 code = Tcl_GlobalEval(interp, script);
253 Tcl_Release((ClientData) script);
254 if (code != TCL_OK) {
255 if (code == TCL_ERROR) {
256 Tcl_AddErrorInfo(interp,
257 "\n (\"package ifneeded\" script)");
258 }
259 return NULL;
260 }
261 Tcl_ResetResult(interp);
262 pkgPtr = FindPackage(interp, name);
263 break;
264 }
265
266 /*
267 * Package not in the database. If there is a "package unknown"
268 * command, invoke it (but only on the first pass; after that,
269 * we should not get here in the first place).
270 */
271
272 if (pass > 1) {
273 break;
274 }
275 script = ((Interp *) interp)->packageUnknown;
276 if (script != NULL) {
277 Tcl_DStringInit(&command);
278 Tcl_DStringAppend(&command, script, -1);
279 Tcl_DStringAppendElement(&command, name);
280 Tcl_DStringAppend(&command, " ", 1);
281 Tcl_DStringAppend(&command, (version != NULL) ? version : "{}",
282 -1);
283 if (exact) {
284 Tcl_DStringAppend(&command, " -exact", 7);
285 }
286 code = Tcl_GlobalEval(interp, Tcl_DStringValue(&command));
287 Tcl_DStringFree(&command);
288 if (code != TCL_OK) {
289 if (code == TCL_ERROR) {
290 Tcl_AddErrorInfo(interp,
291 "\n (\"package unknown\" script)");
292 }
293 return NULL;
294 }
295 Tcl_ResetResult(interp);
296 }
297 }
298
299 if (pkgPtr->version == NULL) {
300 Tcl_AppendResult(interp, "can't find package ", name,
301 (char *) NULL);
302 if (version != NULL) {
303 Tcl_AppendResult(interp, " ", version, (char *) NULL);
304 }
305 return NULL;
306 }
307
308 /*
309 * At this point we know that the package is present. Make sure that the
310 * provided version meets the current requirement.
311 */
312
313 if (version == NULL) {
314 if (clientDataPtr) {
315 *clientDataPtr = pkgPtr->clientData;
316 }
317 return pkgPtr->version;
318 }
319 result = ComparePkgVersions(pkgPtr->version, version, &satisfies);
320 if ((satisfies && !exact) || (result == 0)) {
321 if (clientDataPtr) {
322 *clientDataPtr = pkgPtr->clientData;
323 }
324 return pkgPtr->version;
325 }
326 Tcl_AppendResult(interp, "version conflict for package \"",
327 name, "\": have ", pkgPtr->version, ", need ", version,
328 (char *) NULL);
329 return NULL;
330 }
331
332 /*
333 *----------------------------------------------------------------------
334 *
335 * Tcl_PkgPresent / Tcl_PkgPresentEx --
336 *
337 * Checks to see whether the specified package is present. If it
338 * is not then no additional action is taken.
339 *
340 * Results:
341 * If successful, returns the version string for the currently
342 * provided version of the package, which may be different from
343 * the "version" argument. If the caller's requirements
344 * cannot be met (e.g. the version requested conflicts with
345 * a currently provided version), NULL is returned and an error
346 * message is left in interp->result.
347 *
348 * Side effects:
349 * None.
350 *
351 *----------------------------------------------------------------------
352 */
353
354 char *
355 Tcl_PkgPresent(interp, name, version, exact)
356 Tcl_Interp *interp; /* Interpreter in which package is now
357 * available. */
358 char *name; /* Name of desired package. */
359 char *version; /* Version string for desired version;
360 * NULL means use the latest version
361 * available. */
362 int exact; /* Non-zero means that only the particular
363 * version given is acceptable. Zero means
364 * use the latest compatible version. */
365 {
366 return Tcl_PkgPresentEx(interp, name, version, exact, (ClientData *) NULL);
367 }
368
369 char *
370 Tcl_PkgPresentEx(interp, name, version, exact, clientDataPtr)
371 Tcl_Interp *interp; /* Interpreter in which package is now
372 * available. */
373 char *name; /* Name of desired package. */
374 char *version; /* Version string for desired version;
375 * NULL means use the latest version
376 * available. */
377 int exact; /* Non-zero means that only the particular
378 * version given is acceptable. Zero means
379 * use the latest compatible version. */
380 ClientData *clientDataPtr; /* Used to return the client data for this
381 * package. If it is NULL then the client
382 * data is not returned. This is unchanged
383 * if this call fails for any reason. */
384 {
385 Interp *iPtr = (Interp *) interp;
386 Tcl_HashEntry *hPtr;
387 Package *pkgPtr;
388 int satisfies, result;
389
390 /*
391 * If an attempt is being made to load this into a standalone executable
392 * on a platform where backlinking is not supported then this must be
393 * a shared version of Tcl (Otherwise the load would have failed).
394 * Detect this situation by checking that this library has been correctly
395 * initialised. If it has not been then return immediately as nothing will
396 * work.
397 */
398
399 if (!tclEmptyStringRep) {
400 Tcl_AppendResult(interp, "Cannot load package \"", name,
401 "\" in standalone executable: This package is not ",
402 "compiled with stub support", NULL);
403 return NULL;
404 }
405
406 hPtr = Tcl_FindHashEntry(&iPtr->packageTable, name);
407 if (hPtr) {
408 pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
409 if (pkgPtr->version != NULL) {
410
411 /*
412 * At this point we know that the package is present. Make sure
413 * that the provided version meets the current requirement.
414 */
415
416 if (version == NULL) {
417 if (clientDataPtr) {
418 *clientDataPtr = pkgPtr->clientData;
419 }
420
421 return pkgPtr->version;
422 }
423 result = ComparePkgVersions(pkgPtr->version, version, &satisfies);
424 if ((satisfies && !exact) || (result == 0)) {
425 if (clientDataPtr) {
426 *clientDataPtr = pkgPtr->clientData;
427 }
428
429 return pkgPtr->version;
430 }
431 Tcl_AppendResult(interp, "version conflict for package \"",
432 name, "\": have ", pkgPtr->version,
433 ", need ", version, (char *) NULL);
434 return NULL;
435 }
436 }
437
438 if (version != NULL) {
439 Tcl_AppendResult(interp, "package ", name, " ", version,
440 " is not present", (char *) NULL);
441 } else {
442 Tcl_AppendResult(interp, "package ", name, " is not present",
443 (char *) NULL);
444 }
445 return NULL;
446 }
447
448 /*
449 *----------------------------------------------------------------------
450 *
451 * Tcl_PackageObjCmd --
452 *
453 * This procedure is invoked to process the "package" Tcl command.
454 * See the user documentation for details on what it does.
455 *
456 * Results:
457 * A standard Tcl result.
458 *
459 * Side effects:
460 * See the user documentation.
461 *
462 *----------------------------------------------------------------------
463 */
464
465 /* ARGSUSED */
466 int
467 Tcl_PackageObjCmd(dummy, interp, objc, objv)
468 ClientData dummy; /* Not used. */
469 Tcl_Interp *interp; /* Current interpreter. */
470 int objc; /* Number of arguments. */
471 Tcl_Obj *CONST objv[]; /* Argument objects. */
472 {
473 static char *pkgOptions[] = {
474 "forget", "ifneeded", "names", "present", "provide", "require",
475 "unknown", "vcompare", "versions", "vsatisfies", (char *) NULL
476 };
477 enum pkgOptions {
478 PKG_FORGET, PKG_IFNEEDED, PKG_NAMES, PKG_PRESENT,
479 PKG_PROVIDE, PKG_REQUIRE, PKG_UNKNOWN, PKG_VCOMPARE,
480 PKG_VERSIONS, PKG_VSATISFIES
481 };
482 Interp *iPtr = (Interp *) interp;
483 int optionIndex, exact, i, satisfies;
484 PkgAvail *availPtr, *prevPtr;
485 Package *pkgPtr;
486 Tcl_HashEntry *hPtr;
487 Tcl_HashSearch search;
488 Tcl_HashTable *tablePtr;
489 char *version, *argv2, *argv3, *argv4;
490
491 if (objc < 2) {
492 Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?");
493 return TCL_ERROR;
494 }
495
496 if (Tcl_GetIndexFromObj(interp, objv[1], pkgOptions, "option", 0,
497 &optionIndex) != TCL_OK) {
498 return TCL_ERROR;
499 }
500 switch ((enum pkgOptions) optionIndex) {
501 case PKG_FORGET: {
502 char *keyString;
503 for (i = 2; i < objc; i++) {
504 keyString = Tcl_GetString(objv[i]);
505 hPtr = Tcl_FindHashEntry(&iPtr->packageTable, keyString);
506 if (hPtr == NULL) {
507 return TCL_OK;
508 }
509 pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
510 Tcl_DeleteHashEntry(hPtr);
511 if (pkgPtr->version != NULL) {
512 ckfree(pkgPtr->version);
513 }
514 while (pkgPtr->availPtr != NULL) {
515 availPtr = pkgPtr->availPtr;
516 pkgPtr->availPtr = availPtr->nextPtr;
517 ckfree(availPtr->version);
518 Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC);
519 ckfree((char *) availPtr);
520 }
521 ckfree((char *) pkgPtr);
522 }
523 break;
524 }
525 case PKG_IFNEEDED: {
526 int length;
527 if ((objc != 4) && (objc != 5)) {
528 Tcl_WrongNumArgs(interp, 2, objv, "package version ?script?");
529 return TCL_ERROR;
530 }
531 argv3 = Tcl_GetString(objv[3]);
532 if (CheckVersion(interp, argv3) != TCL_OK) {
533 return TCL_ERROR;
534 }
535 argv2 = Tcl_GetString(objv[2]);
536 if (objc == 4) {
537 hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2);
538 if (hPtr == NULL) {
539 return TCL_OK;
540 }
541 pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
542 } else {
543 pkgPtr = FindPackage(interp, argv2);
544 }
545 argv3 = Tcl_GetStringFromObj(objv[3], &length);
546 for (availPtr = pkgPtr->availPtr, prevPtr = NULL; availPtr != NULL;
547 prevPtr = availPtr, availPtr = availPtr->nextPtr) {
548 if (ComparePkgVersions(availPtr->version, argv3, (int *) NULL)
549 == 0) {
550 if (objc == 4) {
551 Tcl_SetResult(interp, availPtr->script, TCL_VOLATILE);
552 return TCL_OK;
553 }
554 Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC);
555 break;
556 }
557 }
558 if (objc == 4) {
559 return TCL_OK;
560 }
561 if (availPtr == NULL) {
562 availPtr = (PkgAvail *) ckalloc(sizeof(PkgAvail));
563 availPtr->version = ckalloc((unsigned) (length + 1));
564 strcpy(availPtr->version, argv3);
565 if (prevPtr == NULL) {
566 availPtr->nextPtr = pkgPtr->availPtr;
567 pkgPtr->availPtr = availPtr;
568 } else {
569 availPtr->nextPtr = prevPtr->nextPtr;
570 prevPtr->nextPtr = availPtr;
571 }
572 }
573 argv4 = Tcl_GetStringFromObj(objv[4], &length);
574 availPtr->script = ckalloc((unsigned) (length + 1));
575 strcpy(availPtr->script, argv4);
576 break;
577 }
578 case PKG_NAMES: {
579 if (objc != 2) {
580 Tcl_WrongNumArgs(interp, 2, objv, NULL);
581 return TCL_ERROR;
582 }
583 tablePtr = &iPtr->packageTable;
584 for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL;
585 hPtr = Tcl_NextHashEntry(&search)) {
586 pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
587 if ((pkgPtr->version != NULL) || (pkgPtr->availPtr != NULL)) {
588 Tcl_AppendElement(interp, Tcl_GetHashKey(tablePtr, hPtr));
589 }
590 }
591 break;
592 }
593 case PKG_PRESENT: {
594 if (objc < 3) {
595 presentSyntax:
596 Tcl_WrongNumArgs(interp, 2, objv, "?-exact? package ?version?");
597 return TCL_ERROR;
598 }
599 argv2 = Tcl_GetString(objv[2]);
600 if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) {
601 exact = 1;
602 } else {
603 exact = 0;
604 }
605 version = NULL;
606 if (objc == (4 + exact)) {
607 version = Tcl_GetString(objv[3 + exact]);
608 if (CheckVersion(interp, version) != TCL_OK) {
609 return TCL_ERROR;
610 }
611 } else if ((objc != 3) || exact) {
612 goto presentSyntax;
613 }
614 if (exact) {
615 argv3 = Tcl_GetString(objv[3]);
616 version = Tcl_PkgPresent(interp, argv3, version, exact);
617 } else {
618 version = Tcl_PkgPresent(interp, argv2, version, exact);
619 }
620 if (version == NULL) {
621 return TCL_ERROR;
622 }
623 Tcl_SetResult(interp, version, TCL_VOLATILE);
624 break;
625 }
626 case PKG_PROVIDE: {
627 if ((objc != 3) && (objc != 4)) {
628 Tcl_WrongNumArgs(interp, 2, objv, "package ?version?");
629 return TCL_ERROR;
630 }
631 argv2 = Tcl_GetString(objv[2]);
632 if (objc == 3) {
633 hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2);
634 if (hPtr != NULL) {
635 pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
636 if (pkgPtr->version != NULL) {
637 Tcl_SetResult(interp, pkgPtr->version, TCL_VOLATILE);
638 }
639 }
640 return TCL_OK;
641 }
642 argv3 = Tcl_GetString(objv[3]);
643 if (CheckVersion(interp, argv3) != TCL_OK) {
644 return TCL_ERROR;
645 }
646 return Tcl_PkgProvide(interp, argv2, argv3);
647 }
648 case PKG_REQUIRE: {
649 if (objc < 3) {
650 requireSyntax:
651 Tcl_WrongNumArgs(interp, 2, objv, "?-exact? package ?version?");
652 return TCL_ERROR;
653 }
654 argv2 = Tcl_GetString(objv[2]);
655 if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) {
656 exact = 1;
657 } else {
658 exact = 0;
659 }
660 version = NULL;
661 if (objc == (4 + exact)) {
662 version = Tcl_GetString(objv[3 + exact]);
663 if (CheckVersion(interp, version) != TCL_OK) {
664 return TCL_ERROR;
665 }
666 } else if ((objc != 3) || exact) {
667 goto requireSyntax;
668 }
669 if (exact) {
670 argv3 = Tcl_GetString(objv[3]);
671 version = Tcl_PkgRequire(interp, argv3, version, exact);
672 } else {
673 version = Tcl_PkgRequire(interp, argv2, version, exact);
674 }
675 if (version == NULL) {
676 return TCL_ERROR;
677 }
678 Tcl_SetResult(interp, version, TCL_VOLATILE);
679 break;
680 }
681 case PKG_UNKNOWN: {
682 int length;
683 if (objc == 2) {
684 if (iPtr->packageUnknown != NULL) {
685 Tcl_SetResult(interp, iPtr->packageUnknown, TCL_VOLATILE);
686 }
687 } else if (objc == 3) {
688 if (iPtr->packageUnknown != NULL) {
689 ckfree(iPtr->packageUnknown);
690 }
691 argv2 = Tcl_GetStringFromObj(objv[2], &length);
692 if (argv2[0] == 0) {
693 iPtr->packageUnknown = NULL;
694 } else {
695 iPtr->packageUnknown = (char *) ckalloc((unsigned)
696 (length + 1));
697 strcpy(iPtr->packageUnknown, argv2);
698 }
699 } else {
700 Tcl_WrongNumArgs(interp, 2, objv, "?command?");
701 return TCL_ERROR;
702 }
703 break;
704 }
705 case PKG_VCOMPARE: {
706 if (objc != 4) {
707 Tcl_WrongNumArgs(interp, 2, objv, "version1 version2");
708 return TCL_ERROR;
709 }
710 argv3 = Tcl_GetString(objv[3]);
711 argv2 = Tcl_GetString(objv[2]);
712 if ((CheckVersion(interp, argv2) != TCL_OK)
713 || (CheckVersion(interp, argv3) != TCL_OK)) {
714 return TCL_ERROR;
715 }
716 Tcl_SetIntObj(Tcl_GetObjResult(interp),
717 ComparePkgVersions(argv2, argv3, (int *) NULL));
718 break;
719 }
720 case PKG_VERSIONS: {
721 if (objc != 3) {
722 Tcl_WrongNumArgs(interp, 2, objv, "package");
723 return TCL_ERROR;
724 }
725 argv2 = Tcl_GetString(objv[2]);
726 hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2);
727 if (hPtr != NULL) {
728 pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
729 for (availPtr = pkgPtr->availPtr; availPtr != NULL;
730 availPtr = availPtr->nextPtr) {
731 Tcl_AppendElement(interp, availPtr->version);
732 }
733 }
734 break;
735 }
736 case PKG_VSATISFIES: {
737 if (objc != 4) {
738 Tcl_WrongNumArgs(interp, 2, objv, "version1 version2");
739 return TCL_ERROR;
740 }
741 argv3 = Tcl_GetString(objv[3]);
742 argv2 = Tcl_GetString(objv[2]);
743 if ((CheckVersion(interp, argv2) != TCL_OK)
744 || (CheckVersion(interp, argv3) != TCL_OK)) {
745 return TCL_ERROR;
746 }
747 ComparePkgVersions(argv2, argv3, &satisfies);
748 Tcl_SetIntObj(Tcl_GetObjResult(interp), satisfies);
749 break;
750 }
751 default: {
752 panic("Tcl_PackageObjCmd: bad option index to pkgOptions");
753 }
754 }
755 return TCL_OK;
756 }
757
758 /*
759 *----------------------------------------------------------------------
760 *
761 * FindPackage --
762 *
763 * This procedure finds the Package record for a particular package
764 * in a particular interpreter, creating a record if one doesn't
765 * already exist.
766 *
767 * Results:
768 * The return value is a pointer to the Package record for the
769 * package.
770 *
771 * Side effects:
772 * A new Package record may be created.
773 *
774 *----------------------------------------------------------------------
775 */
776
777 static Package *
778 FindPackage(interp, name)
779 Tcl_Interp *interp; /* Interpreter to use for package lookup. */
780 char *name; /* Name of package to fine. */
781 {
782 Interp *iPtr = (Interp *) interp;
783 Tcl_HashEntry *hPtr;
784 int new;
785 Package *pkgPtr;
786
787 hPtr = Tcl_CreateHashEntry(&iPtr->packageTable, name, &new);
788 if (new) {
789 pkgPtr = (Package *) ckalloc(sizeof(Package));
790 pkgPtr->version = NULL;
791 pkgPtr->availPtr = NULL;
792 pkgPtr->clientData = NULL;
793 Tcl_SetHashValue(hPtr, pkgPtr);
794 } else {
795 pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
796 }
797 return pkgPtr;
798 }
799
800 /*
801 *----------------------------------------------------------------------
802 *
803 * TclFreePackageInfo --
804 *
805 * This procedure is called during interpreter deletion to
806 * free all of the package-related information for the
807 * interpreter.
808 *
809 * Results:
810 * None.
811 *
812 * Side effects:
813 * Memory is freed.
814 *
815 *----------------------------------------------------------------------
816 */
817
818 void
819 TclFreePackageInfo(iPtr)
820 Interp *iPtr; /* Interpereter that is being deleted. */
821 {
822 Package *pkgPtr;
823 Tcl_HashSearch search;
824 Tcl_HashEntry *hPtr;
825 PkgAvail *availPtr;
826
827 for (hPtr = Tcl_FirstHashEntry(&iPtr->packageTable, &search);
828 hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
829 pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
830 if (pkgPtr->version != NULL) {
831 ckfree(pkgPtr->version);
832 }
833 while (pkgPtr->availPtr != NULL) {
834 availPtr = pkgPtr->availPtr;
835 pkgPtr->availPtr = availPtr->nextPtr;
836 ckfree(availPtr->version);
837 Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC);
838 ckfree((char *) availPtr);
839 }
840 ckfree((char *) pkgPtr);
841 }
842 Tcl_DeleteHashTable(&iPtr->packageTable);
843 if (iPtr->packageUnknown != NULL) {
844 ckfree(iPtr->packageUnknown);
845 }
846 }
847
848 /*
849 *----------------------------------------------------------------------
850 *
851 * CheckVersion --
852 *
853 * This procedure checks to see whether a version number has
854 * valid syntax.
855 *
856 * Results:
857 * If string is a properly formed version number the TCL_OK
858 * is returned. Otherwise TCL_ERROR is returned and an error
859 * message is left in the interp's result.
860 *
861 * Side effects:
862 * None.
863 *
864 *----------------------------------------------------------------------
865 */
866
867 static int
868 CheckVersion(interp, string)
869 Tcl_Interp *interp; /* Used for error reporting. */
870 char *string; /* Supposedly a version number, which is
871 * groups of decimal digits separated
872 * by dots. */
873 {
874 char *p = string;
875 char prevChar;
876
877 if (!isdigit(UCHAR(*p))) { /* INTL: digit */
878 goto error;
879 }
880 for (prevChar = *p, p++; *p != 0; p++) {
881 if (!isdigit(UCHAR(*p)) &&
882 ((*p != '.') || (prevChar == '.'))) { /* INTL: digit */
883 goto error;
884 }
885 prevChar = *p;
886 }
887 if (prevChar != '.') {
888 return TCL_OK;
889 }
890
891 error:
892 Tcl_AppendResult(interp, "expected version number but got \"",
893 string, "\"", (char *) NULL);
894 return TCL_ERROR;
895 }
896
897 /*
898 *----------------------------------------------------------------------
899 *
900 * ComparePkgVersions --
901 *
902 * This procedure compares two version numbers.
903 *
904 * Results:
905 * The return value is -1 if v1 is less than v2, 0 if the two
906 * version numbers are the same, and 1 if v1 is greater than v2.
907 * If *satPtr is non-NULL, the word it points to is filled in
908 * with 1 if v2 >= v1 and both numbers have the same major number
909 * or 0 otherwise.
910 *
911 * Side effects:
912 * None.
913 *
914 *----------------------------------------------------------------------
915 */
916
917 static int
918 ComparePkgVersions(v1, v2, satPtr)
919 char *v1, *v2; /* Versions strings, of form 2.1.3 (any
920 * number of version numbers). */
921 int *satPtr; /* If non-null, the word pointed to is
922 * filled in with a 0/1 value. 1 means
923 * v1 "satisfies" v2: v1 is greater than
924 * or equal to v2 and both version numbers
925 * have the same major number. */
926 {
927 int thisIsMajor, n1, n2;
928
929 /*
930 * Each iteration of the following loop processes one number from
931 * each string, terminated by a ".". If those numbers don't match
932 * then the comparison is over; otherwise, we loop back for the
933 * next number.
934 */
935
936 thisIsMajor = 1;
937 while (1) {
938 /*
939 * Parse one decimal number from the front of each string.
940 */
941
942 n1 = n2 = 0;
943 while ((*v1 != 0) && (*v1 != '.')) {
944 n1 = 10*n1 + (*v1 - '0');
945 v1++;
946 }
947 while ((*v2 != 0) && (*v2 != '.')) {
948 n2 = 10*n2 + (*v2 - '0');
949 v2++;
950 }
951
952 /*
953 * Compare and go on to the next version number if the
954 * current numbers match.
955 */
956
957 if (n1 != n2) {
958 break;
959 }
960 if (*v1 != 0) {
961 v1++;
962 } else if (*v2 == 0) {
963 break;
964 }
965 if (*v2 != 0) {
966 v2++;
967 }
968 thisIsMajor = 0;
969 }
970 if (satPtr != NULL) {
971 *satPtr = (n1 == n2) || ((n1 > n2) && !thisIsMajor);
972 }
973 if (n1 > n2) {
974 return 1;
975 } else if (n1 == n2) {
976 return 0;
977 } else {
978 return -1;
979 }
980 }
981
982 /* End of tclpkg.c */

Properties

Name Value
svn:keywords Header

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25