/[dtapublic]/to_be_filed/sf_code/esrgpcpj/shared/tcl_base/tclpkg.c
ViewVC logotype

Contents of /to_be_filed/sf_code/esrgpcpj/shared/tcl_base/tclpkg.c

Parent Directory Parent Directory | Revision Log Revision Log


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

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25