Tcl Source Code

Check-in [46fd14dcfe]
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to tclconference@googlegroups.com
or submit via the online form by Sep 9.

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Add remaining wrapper to the NR functions, remaining calls to TCL_NRAddCallback, and a test for a package require script that yields.

DGP: This checkin introduces a memleak, detected by test compExpr-7.1.

Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | core-8-6-branch
Files: files | file ages | folders
SHA3-256:46fd14dcfecafbf0be0305b77d22697a63b110a3fa456baca792b03003dec439
User & Date: pooryorick 2018-02-12 12:40:34
Original Comment: Add remaining wrapper to the NR functions, remaining calls to TCL_NRAddCallback, and a test for a package require script that yields.
Context
2018-02-14
10:46
Fix for issue 9fd5c629c1, TclOO - aborts when a trace on command deletion deletes the object's names... check-in: 77641f0360 user: pooryorick
2018-02-13
20:51
New test expr-32.7 for bignum modulus range. check-in: 8afeaf8fcf user: dgp tags: core-8-6-branch
18:55
Implemetation of tip 501.

Note: The build fails with:

bad stack depth computations: is 0, should b... check-in: 46ed8c3c33 user: hypnotoad tags: tip-501

2018-02-12
23:57
Merge updates from 8.6 branch. check-in: 4ff7fe6ca3 user: mistachkin tags: irontcl
12:40
Add remaining wrapper to the NR functions, remaining calls to TCL_NRAddCallback, and a test for a p... check-in: 46fd14dcfe user: pooryorick tags: core-8-6-branch
10:44
Adapt signature of PkgRequireCore to conform to Tcl_ObjCmdProc, and call it in Tcl_PkgRequireProc on... check-in: 733559b5b6 user: pooryorick tags: core-8-6-branch
2018-02-06
11:16
Add remaining wrapper to the NR functions, remaining calls to TCL_NRAddCallback, and a test for a pa... Closed-Leaf check-in: 1be00566c4 user: pooryorick tags: py-package-nre
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to generic/tclBasic.c.

230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
....
4423
4424
4425
4426
4427
4428
4429


4430
4431
4432
4433
4434
4435
4436
    {"lrange",		Tcl_LrangeObjCmd,	TclCompileLrangeCmd,	NULL,	CMD_IS_SAFE},
    {"lrepeat",		Tcl_LrepeatObjCmd,	NULL,			NULL,	CMD_IS_SAFE},
    {"lreplace",	Tcl_LreplaceObjCmd,	TclCompileLreplaceCmd,	NULL,	CMD_IS_SAFE},
    {"lreverse",	Tcl_LreverseObjCmd,	NULL,			NULL,	CMD_IS_SAFE},
    {"lsearch",		Tcl_LsearchObjCmd,	NULL,			NULL,	CMD_IS_SAFE},
    {"lset",		Tcl_LsetObjCmd,		TclCompileLsetCmd,	NULL,	CMD_IS_SAFE},
    {"lsort",		Tcl_LsortObjCmd,	NULL,			NULL,	CMD_IS_SAFE},
    {"package",		Tcl_PackageObjCmd,	NULL,			NULL,	CMD_IS_SAFE},
    {"proc",		Tcl_ProcObjCmd,		NULL,			NULL,	CMD_IS_SAFE},
    {"regexp",		Tcl_RegexpObjCmd,	TclCompileRegexpCmd,	NULL,	CMD_IS_SAFE},
    {"regsub",		Tcl_RegsubObjCmd,	TclCompileRegsubCmd,	NULL,	CMD_IS_SAFE},
    {"rename",		Tcl_RenameObjCmd,	NULL,			NULL,	CMD_IS_SAFE},
    {"return",		Tcl_ReturnObjCmd,	TclCompileReturnCmd,	NULL,	CMD_IS_SAFE},
    {"scan",		Tcl_ScanObjCmd,		NULL,			NULL,	CMD_IS_SAFE},
    {"set",		Tcl_SetObjCmd,		TclCompileSetCmd,	NULL,	CMD_IS_SAFE},
................................................................................
     * This only needs to be done for the first item in the list: all other
     * are for NR function calls, and those are Tcl_Obj based.
     */

    if (*(iPtr->result) != 0) {
	(void) Tcl_GetObjResult(interp);
    }



    while (TOP_CB(interp) != rootPtr) {
	callbackPtr = TOP_CB(interp);
	procPtr = callbackPtr->procPtr;
	TOP_CB(interp) = callbackPtr->nextPtr;
	result = procPtr(callbackPtr->data, interp, result);
	TCLNR_FREE(interp, callbackPtr);







|







 







>
>







230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
....
4423
4424
4425
4426
4427
4428
4429
4430
4431
4432
4433
4434
4435
4436
4437
4438
    {"lrange",		Tcl_LrangeObjCmd,	TclCompileLrangeCmd,	NULL,	CMD_IS_SAFE},
    {"lrepeat",		Tcl_LrepeatObjCmd,	NULL,			NULL,	CMD_IS_SAFE},
    {"lreplace",	Tcl_LreplaceObjCmd,	TclCompileLreplaceCmd,	NULL,	CMD_IS_SAFE},
    {"lreverse",	Tcl_LreverseObjCmd,	NULL,			NULL,	CMD_IS_SAFE},
    {"lsearch",		Tcl_LsearchObjCmd,	NULL,			NULL,	CMD_IS_SAFE},
    {"lset",		Tcl_LsetObjCmd,		TclCompileLsetCmd,	NULL,	CMD_IS_SAFE},
    {"lsort",		Tcl_LsortObjCmd,	NULL,			NULL,	CMD_IS_SAFE},
    {"package",		Tcl_PackageObjCmd,	NULL,			TclNRPackageObjCmd,	CMD_IS_SAFE},
    {"proc",		Tcl_ProcObjCmd,		NULL,			NULL,	CMD_IS_SAFE},
    {"regexp",		Tcl_RegexpObjCmd,	TclCompileRegexpCmd,	NULL,	CMD_IS_SAFE},
    {"regsub",		Tcl_RegsubObjCmd,	TclCompileRegsubCmd,	NULL,	CMD_IS_SAFE},
    {"rename",		Tcl_RenameObjCmd,	NULL,			NULL,	CMD_IS_SAFE},
    {"return",		Tcl_ReturnObjCmd,	TclCompileReturnCmd,	NULL,	CMD_IS_SAFE},
    {"scan",		Tcl_ScanObjCmd,		NULL,			NULL,	CMD_IS_SAFE},
    {"set",		Tcl_SetObjCmd,		TclCompileSetCmd,	NULL,	CMD_IS_SAFE},
................................................................................
     * This only needs to be done for the first item in the list: all other
     * are for NR function calls, and those are Tcl_Obj based.
     */

    if (*(iPtr->result) != 0) {
	(void) Tcl_GetObjResult(interp);
    }

    /* This is the trampoline. */

    while (TOP_CB(interp) != rootPtr) {
	callbackPtr = TOP_CB(interp);
	procPtr = callbackPtr->procPtr;
	TOP_CB(interp) = callbackPtr->nextPtr;
	result = procPtr(callbackPtr->data, interp, result);
	TCLNR_FREE(interp, callbackPtr);

Changes to generic/tclPkg.c.

49
50
51
52
53
54
55

56





57
58
59
60
61
62
63
..
71
72
73
74
75
76
77
78
79
80
81





82
83
84
85
86
87
88
...
336
337
338
339
340
341
342























343
344
345
346
347


348
349
350
351





352

353
354
355
356
357
358
359
360
361
362
363
364
365


366

367
368


369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385


386
387
388
389
390


391
392

393
394




395









396
397
398
399
400
401
402
403
404
405
406
407
408
409
410

411
412
413
414
415
416








417
418
419
420
421
422
423
...
447
448
449
450
451
452
453
454
455








456
457
458
459
460



461
462
463
464
465
466
467
...
590
591
592
593
594
595
596
597


598
599
600
601
602
603
604
605
606
607
608
609
610


611
612
613











614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690

691
692
693
694
695
696
697
...
790
791
792
793
794
795
796









797
798
799
800
801
802
803
804
805
806
807
...
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825

826
827
828
829
830
831
832
....
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
....
1042
1043
1044
1045
1046
1047
1048

1049
1050
1051

1052

1053
1054
1055





1056
1057


1058
1059
1060




1061
1062











1063
1064
1065
1066
1067
1068
1069
....
1195
1196
1197
1198
1199
1200
1201







1202
1203
1204
1205
1206
1207
1208
    const void *clientData;	/* Client data. */
} Package;

typedef struct Require {
    void * clientDataPtr;
    const char *name;
    Package *pkgPtr;

} Require;






/*
 * Prototypes for functions defined in this file:
 */

static int		CheckVersionAndConvert(Tcl_Interp *interp,
			    const char *string, char **internal, int *stable);
................................................................................
static int		SomeRequirementSatisfied(char *havei, int reqc,
			    Tcl_Obj *const reqv[]);
static void		AddRequirementsToResult(Tcl_Interp *interp, int reqc,
			    Tcl_Obj *const reqv[]);
static void		AddRequirementsToDString(Tcl_DString *dstring,
			    int reqc, Tcl_Obj *const reqv[]);
static Package *	FindPackage(Tcl_Interp *interp, const char *name);
static int		PkgRequireCore(ClientData clientData, Tcl_Interp *interp,
			    int reqc, Tcl_Obj *const reqv[]);
static int		SelectPackage (Tcl_Interp *interp, Require *reqPtr,
			    int reqc, Tcl_Obj *const reqv[]);






/*
 * Helper macros.
 */

#define DupBlock(v,s,len) \
    ((v) = ckalloc(len), memcpy((v),(s),(len)))
................................................................................
    const char *name,		/* Name of desired package. */
    int reqc,			/* Requirements constraining the desired
				 * version. */
    Tcl_Obj *const reqv[],	/* 0 means to use the latest version
				 * available. */
    void *clientDataPtr)
{























    int code = CheckAllRequirements(interp, reqc, reqv);
    Require require;
    if (code != TCL_OK) {
	return code;
    }


    require.clientDataPtr = clientDataPtr;
    require.name = name;
    require.pkgPtr = NULL;
    return Tcl_NRCallObjProc(interp, PkgRequireCore, &require, reqc, reqv);





}


int
PkgRequireCore(
    ClientData clientData,
    Tcl_Interp *interp,		/* Interpreter in which package is now
				 * available. */
    int reqc,			/* Requirements constraining the desired
				 * version. */
    Tcl_Obj *const reqv[]	/* 0 means to use the latest version
				 * available. */
    )
{
    int code, satisfies;


    Tcl_DString command;

    Require *reqPtr = clientData;
    char *script, *pkgVersionI;


    const char *name = reqPtr->name /* Name of desired package. */;
    void *clientDataPtr = reqPtr->clientDataPtr;

    reqPtr->pkgPtr = FindPackage(interp, name);
    if (reqPtr->pkgPtr->version == NULL) {
	code = SelectPackage(interp, reqPtr, reqc, reqv);
	if (code != TCL_OK) {
	    return code;
	}
	if (reqPtr->pkgPtr->version == NULL) {
		/*
		 * The package is not in the database. If there is a "package unknown"
		 * command, invoke it.
		 */

		script = ((Interp *) interp)->packageUnknown;
		if (script != NULL) {


		    Tcl_DStringInit(&command);
		    Tcl_DStringAppend(&command, script, -1);
		    Tcl_DStringAppendElement(&command, name);
		    AddRequirementsToDString(&command, reqc, reqv);



		    code = Tcl_EvalEx(interp, Tcl_DStringValue(&command),
			    Tcl_DStringLength(&command), TCL_EVAL_GLOBAL);

		    Tcl_DStringFree(&command);





		    if ((code != TCL_OK) && (code != TCL_ERROR)) {









			Tcl_SetObjResult(interp, Tcl_ObjPrintf(
				"bad return code: %d", code));
			Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL);
			code = TCL_ERROR;
		    }
		    if (code == TCL_ERROR) {
			Tcl_AddErrorInfo(interp,
				"\n    (\"package unknown\" script)");
			return code;
		    }
		    Tcl_ResetResult(interp);
		    /* pkgPtr may now be invalid, so refresh it. */
		    reqPtr->pkgPtr = FindPackage(interp, name);
		    code = SelectPackage(interp, reqPtr, reqc, reqv);
		    if (code != TCL_OK) {

			return code;
		    }
		}
	}
    }









    if (reqPtr->pkgPtr->version == NULL) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"can't find package %s", name));
	Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNFOUND", NULL);
	AddRequirementsToResult(interp, reqc, reqv);
	return TCL_ERROR;
    }
................................................................................
	const void **ptr = (const void **) clientDataPtr;

	*ptr = reqPtr->pkgPtr->clientData;
    }
    Tcl_SetObjResult(interp, Tcl_NewStringObj(reqPtr->pkgPtr->version, -1));
    return TCL_OK;
}
 
int SelectPackage (Tcl_Interp *interp, Require *reqPtr, int reqc, Tcl_Obj *const reqv[]) {








    PkgAvail *availPtr, *bestPtr, *bestStablePtr;
    char *availVersion, *bestVersion, *bestStableVersion;
				/* Internal rep. of versions */
    char *script;
    int availStable, code, satisfies; 



    const char *name = reqPtr->name;
    Package *pkgPtr = reqPtr->pkgPtr;
    Interp *iPtr = (Interp *) interp;

    /*
     * Check whether we're already attempting to load some version of this
     * package (circular dependency detection).
................................................................................
     */

    if ((iPtr->packagePrefer == PKG_PREFER_STABLE)
	    && (bestStablePtr != NULL)) {
	bestPtr = bestStablePtr;
    }

    if (bestPtr != NULL) {


	/*
	 * We found an ifneeded script for the package. Be careful while
	 * executing it: this could cause reentrancy, so (a) protect the
	 * script itself from deletion and (b) don't assume that bestPtr
	 * will still exist when the script completes.
	 */

	char *versionToProvide = bestPtr->version;
	script = bestPtr->script;

	pkgPtr->clientData = versionToProvide;
	Tcl_Preserve(script);
	Tcl_Preserve(versionToProvide);


	code = Tcl_EvalEx(interp, script, -1, TCL_EVAL_GLOBAL);
	Tcl_Release(script);












	reqPtr->pkgPtr = FindPackage(interp, name);
	if (code == TCL_OK) {
	    Tcl_ResetResult(interp);
	    if (reqPtr->pkgPtr->version == NULL) {
		code = TCL_ERROR;
		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			"attempt to provide package %s %s failed:"
			" no version of package %s provided",
			name, versionToProvide, name));
		Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNPROVIDED",
			NULL);
	    } else {
		char *pvi, *vi;

		if (CheckVersionAndConvert(interp, reqPtr->pkgPtr->version, &pvi,
			NULL) != TCL_OK) {
		    code = TCL_ERROR;
		} else if (CheckVersionAndConvert(interp,
			versionToProvide, &vi, NULL) != TCL_OK) {
		    ckfree(pvi);
		    code = TCL_ERROR;
		} else {
		    int res = CompareVersions(pvi, vi, NULL);

		    ckfree(pvi);
		    ckfree(vi);
		    if (res != 0) {
			code = TCL_ERROR;
			Tcl_SetObjResult(interp, Tcl_ObjPrintf(
				"attempt to provide package %s %s failed:"
				" package %s %s provided instead",
				name, versionToProvide,
				name, reqPtr->pkgPtr->version));
			Tcl_SetErrorCode(interp, "TCL", "PACKAGE",
				"WRONGPROVIDE", NULL);
		    }
		}
	    }
	} else if (code != TCL_ERROR) {
	    Tcl_Obj *codePtr = Tcl_NewIntObj(code);

	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "attempt to provide package %s %s failed:"
		    " bad return code: %s",
		    name, versionToProvide, TclGetString(codePtr)));
	    Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL);
	    TclDecrRefCount(codePtr);
	    code = TCL_ERROR;
	}

	if (code == TCL_ERROR) {
	    Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
		    "\n    (\"package ifneeded %s %s\" script)",
		    name, versionToProvide));
	}
	Tcl_Release(versionToProvide);

	if (code != TCL_OK) {
	    /*
	     * Take a non-TCL_OK code from the script as an indication the
	     * package wasn't loaded properly, so the package system
	     * should not remember an improper load.
	     *
	     * This is consistent with our returning NULL. If we're not
	     * willing to tell our caller we got a particular version, we
	     * shouldn't store that version for telling future callers
	     * either.
	     */

	    if (reqPtr->pkgPtr->version != NULL) {
		ckfree(reqPtr->pkgPtr->version);
		reqPtr->pkgPtr->version = NULL;
	    }
	    reqPtr->pkgPtr->clientData = NULL;
	    return code;
	}
    }

    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_PkgPresent / Tcl_PkgPresentEx --
................................................................................
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */










	/* ARGSUSED */
int
Tcl_PackageObjCmd(
    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    static const char *const pkgOptions[] = {
	"forget",  "ifneeded", "names",   "prefer",   "present",
................................................................................
    };
    enum pkgOptions {
	PKG_FORGET,  PKG_IFNEEDED, PKG_NAMES,   PKG_PREFER,   PKG_PRESENT,
	PKG_PROVIDE, PKG_REQUIRE,  PKG_UNKNOWN, PKG_VCOMPARE, PKG_VERSIONS,
	PKG_VSATISFIES
    };
    Interp *iPtr = (Interp *) interp;
    int optionIndex, exact, i, satisfies;
    PkgAvail *availPtr, *prevPtr;
    Package *pkgPtr;
    Tcl_HashEntry *hPtr;
    Tcl_HashSearch search;
    Tcl_HashTable *tablePtr;
    const char *version;
    const char *argv2, *argv3, *argv4;
    char *iva = NULL, *ivb = NULL;


    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
	return TCL_ERROR;
    }

    if (Tcl_GetIndexFromObj(interp, objv[1], pkgOptions, "option", 0,
................................................................................
	}

	version = NULL;

	argv2 = TclGetString(objv[2]);
	if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) {
	    Tcl_Obj *ov;
	    int res;

	    if (objc != 5) {
		goto requireSyntax;
	    }

	    version = TclGetString(objv[4]);
	    if (CheckVersionAndConvert(interp, version, NULL,
................................................................................
	    }

	    /*
	     * Create a new-style requirement for the exact version.
	     */

	    ov = Tcl_NewStringObj(version, -1);

	    Tcl_AppendStringsToObj(ov, "-", version, NULL);
	    version = NULL;
	    argv3 = TclGetString(objv[3]);



	    Tcl_IncrRefCount(ov);
	    res = Tcl_PkgRequireProc(interp, argv3, 1, &ov, NULL);
	    TclDecrRefCount(ov);





	    return res;
	} else {


	    if (CheckAllRequirements(interp, objc-3, objv+3) != TCL_OK) {
		return TCL_ERROR;
	    }





	    return Tcl_PkgRequireProc(interp, argv2, objc-3, objv+3, NULL);











	}
	break;
    case PKG_UNKNOWN: {
	int length;

	if (objc == 2) {
	    if (iPtr->packageUnknown != NULL) {
................................................................................
	break;
    }
    default:
	Tcl_Panic("Tcl_PackageObjCmd: bad option index to pkgOptions");
    }
    return TCL_OK;
}







 
/*
 *----------------------------------------------------------------------
 *
 * FindPackage --
 *
 *	This function finds the Package record for a particular package in a







>

>
>
>
>
>







 







|
|
|
|
>
>
>
>
>







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

|



>
>
|
|
<
<
>
>
>
>
>
|
>
|
<
<
<
<
<
<
<
<
<
|
<
<
>
>

>
|
<
>
>

<
<
<

<
<
<
<
<
|
|
|
|

|
|
>
>
|
|
|
|

>
>
|
|
>
|
|
>
>
>
>
|
>
>
>
>
>
>
>
>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
<
<
>
|
|
|
<
<
<
>
>
>
>
>
>
>
>







 







|
|
>
>
>
>
>
>
>
>



<
|
>
>
>







 







|
>
>








<


<

>
>
|
<
|
>
>
>
>
>
>
>
>
>
>
>
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|

|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
>







 







>
>
>
>
>
>
>
>
>



|







 







|








>







 







<







 







>



>

>
|
<
<
>
>
>
>
>
|

>
>



>
>
>
>

<
>
>
>
>
>
>
>
>
>
>
>







 







>
>
>
>
>
>
>







49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
..
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
...
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385


386
387
388
389
390
391
392
393









394


395
396
397
398
399

400
401
402



403





404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451


452
453
454
455



456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
...
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513

514
515
516
517
518
519
520
521
522
523
524
...
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664

665
666

667
668
669
670

671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
...
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
...
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
....
1105
1106
1107
1108
1109
1110
1111

1112
1113
1114
1115
1116
1117
1118
....
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135


1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152

1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
....
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
    const void *clientData;	/* Client data. */
} Package;

typedef struct Require {
    void * clientDataPtr;
    const char *name;
    Package *pkgPtr;
    char *versionToProvide;
} Require;

typedef struct RequireProcArgs {
    const char *name;
    void *clientDataPtr;
} RequireProcArgs;

/*
 * Prototypes for functions defined in this file:
 */

static int		CheckVersionAndConvert(Tcl_Interp *interp,
			    const char *string, char **internal, int *stable);
................................................................................
static int		SomeRequirementSatisfied(char *havei, int reqc,
			    Tcl_Obj *const reqv[]);
static void		AddRequirementsToResult(Tcl_Interp *interp, int reqc,
			    Tcl_Obj *const reqv[]);
static void		AddRequirementsToDString(Tcl_DString *dstring,
			    int reqc, Tcl_Obj *const reqv[]);
static Package *	FindPackage(Tcl_Interp *interp, const char *name);
static int		PkgRequireCore(ClientData data[], Tcl_Interp *interp, int result);
static int		PkgRequireCoreFinal(ClientData data[], Tcl_Interp *interp, int result);
static int		PkgRequireCoreCleanup(ClientData data[], Tcl_Interp *interp, int result);
static int		PkgRequireCoreStep1(ClientData data[], Tcl_Interp *interp, int result);
static int		PkgRequireCoreStep2(ClientData data[], Tcl_Interp *interp, int result);
static int		TclNRPkgRequireProc(ClientData clientData, Tcl_Interp *interp, int reqc, Tcl_Obj *const reqv[]);
static int		SelectPackage(ClientData data[], Tcl_Interp *interp, int result);
static int		SelectPackageFinal(ClientData data[], Tcl_Interp *interp, int result);
static int		TclNRPackageObjCmdCleanup(ClientData data[], Tcl_Interp *interp, int result);

/*
 * Helper macros.
 */

#define DupBlock(v,s,len) \
    ((v) = ckalloc(len), memcpy((v),(s),(len)))
................................................................................
    const char *name,		/* Name of desired package. */
    int reqc,			/* Requirements constraining the desired
				 * version. */
    Tcl_Obj *const reqv[],	/* 0 means to use the latest version
				 * available. */
    void *clientDataPtr)
{
    RequireProcArgs args;
    args.name = name;
    args.clientDataPtr = clientDataPtr;
    return Tcl_NRCallObjProc(interp, TclNRPkgRequireProc, (void *)&args, reqc, reqv);
}

static int
TclNRPkgRequireProc(
    ClientData clientData,
    Tcl_Interp *interp,
    int reqc,
    Tcl_Obj *const reqv[]) {
    RequireProcArgs *args = clientData;
    Tcl_NRAddCallback(interp, PkgRequireCore, (void *)args->name, INT2PTR(reqc), (void *)reqv, args->clientDataPtr);
    return TCL_OK;
}

static int
PkgRequireCore(ClientData data[], Tcl_Interp *interp, int result)
{
    const char *name = data[0];
    int reqc = PTR2INT(data[1]);
    Tcl_Obj *const *reqv = data[2];
    int code = CheckAllRequirements(interp, reqc, reqv);
    Require *reqPtr;
    if (code != TCL_OK) {
	return code;
    }
    reqPtr = ckalloc(sizeof(Require));
    Tcl_NRAddCallback(interp, PkgRequireCoreCleanup, reqPtr, NULL, NULL, NULL);
    reqPtr->clientDataPtr = data[3];
    reqPtr->name = name;


    reqPtr->pkgPtr = FindPackage(interp, name);
    if (reqPtr->pkgPtr->version == NULL) {
	Tcl_NRAddCallback(interp, SelectPackage, reqPtr, INT2PTR(reqc), (void *)reqv, PkgRequireCoreStep1);
    } else {
	Tcl_NRAddCallback(interp, PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), (void *)reqv, NULL);
    }
    return TCL_OK;
}












static int
PkgRequireCoreStep1(ClientData data[], Tcl_Interp *interp, int result) {
    Tcl_DString command;
    char *script;
    Require *reqPtr = data[0];

    int reqc = PTR2INT(data[1]);
    Tcl_Obj **const reqv = data[2];
    const char *name = reqPtr->name /* Name of desired package. */;



    if (reqPtr->pkgPtr->version == NULL) {





	    /*
	     * The package is not in the database. If there is a "package unknown"
	     * command, invoke it.
	     */

	    script = ((Interp *) interp)->packageUnknown;
	    if (script == NULL) {
		Tcl_NRAddCallback(interp, PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), (void *)reqv, NULL);
	    } else {
		Tcl_DStringInit(&command);
		Tcl_DStringAppend(&command, script, -1);
		Tcl_DStringAppendElement(&command, name);
		AddRequirementsToDString(&command, reqc, reqv);

		Tcl_NRAddCallback(interp, PkgRequireCoreStep2, reqPtr, INT2PTR(reqc), (void *)reqv, NULL);
		Tcl_NREvalObj(interp,
		    Tcl_NewStringObj(Tcl_DStringValue(&command), Tcl_DStringLength(&command)),
		    TCL_EVAL_GLOBAL
		);
		Tcl_DStringFree(&command);
	    }
	    return TCL_OK;
    } else {
	Tcl_NRAddCallback(interp, PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), (void *)reqv, NULL);
    }
    return TCL_OK;
}

static int
PkgRequireCoreStep2(ClientData data[], Tcl_Interp *interp, int result) {
    Require *reqPtr = data[0];
    int reqc = PTR2INT(data[1]);
    Tcl_Obj **const reqv = data[2];
    const char *name = reqPtr->name /* Name of desired package. */;
    if ((result != TCL_OK) && (result != TCL_ERROR)) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"bad return code: %d", result));
	Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL);
	result = TCL_ERROR;
    }
    if (result == TCL_ERROR) {
	Tcl_AddErrorInfo(interp,
		"\n    (\"package unknown\" script)");
	return result;
    }
    Tcl_ResetResult(interp);
    /* pkgPtr may now be invalid, so refresh it. */
    reqPtr->pkgPtr = FindPackage(interp, name);


    Tcl_NRAddCallback(interp, SelectPackage, reqPtr, INT2PTR(reqc), (void *)reqv, PkgRequireCoreFinal);
    return TCL_OK;
}




static int
PkgRequireCoreFinal(ClientData data[], Tcl_Interp *interp, int result) {
    Require *reqPtr = data[0];
    int reqc = PTR2INT(data[1]), satisfies;
    Tcl_Obj **const reqv = data[2];
    char *pkgVersionI;
    void *clientDataPtr = reqPtr->clientDataPtr;
    const char *name = reqPtr->name /* Name of desired package. */;
    if (reqPtr->pkgPtr->version == NULL) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"can't find package %s", name));
	Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNFOUND", NULL);
	AddRequirementsToResult(interp, reqc, reqv);
	return TCL_ERROR;
    }
................................................................................
	const void **ptr = (const void **) clientDataPtr;

	*ptr = reqPtr->pkgPtr->clientData;
    }
    Tcl_SetObjResult(interp, Tcl_NewStringObj(reqPtr->pkgPtr->version, -1));
    return TCL_OK;
}

static int
PkgRequireCoreCleanup(ClientData data[], Tcl_Interp *interp, int result) {
    ckfree(data[0]);
    return result;
}

 
static int
SelectPackage(ClientData data[], Tcl_Interp *interp, int result) {
    PkgAvail *availPtr, *bestPtr, *bestStablePtr;
    char *availVersion, *bestVersion, *bestStableVersion;
				/* Internal rep. of versions */

    int availStable, satisfies; 
    Require *reqPtr = data[0];
    int reqc = PTR2INT(data[1]);
    Tcl_Obj **const reqv = data[2];
    const char *name = reqPtr->name;
    Package *pkgPtr = reqPtr->pkgPtr;
    Interp *iPtr = (Interp *) interp;

    /*
     * Check whether we're already attempting to load some version of this
     * package (circular dependency detection).
................................................................................
     */

    if ((iPtr->packagePrefer == PKG_PREFER_STABLE)
	    && (bestStablePtr != NULL)) {
	bestPtr = bestStablePtr;
    }

    if (bestPtr == NULL) {
	Tcl_NRAddCallback(interp, data[3], reqPtr, INT2PTR(reqc), (void *)reqv, NULL);
    } else {
	/*
	 * We found an ifneeded script for the package. Be careful while
	 * executing it: this could cause reentrancy, so (a) protect the
	 * script itself from deletion and (b) don't assume that bestPtr
	 * will still exist when the script completes.
	 */

	char *versionToProvide = bestPtr->version;


	pkgPtr->clientData = versionToProvide;

	Tcl_Preserve(versionToProvide);
	reqPtr->versionToProvide = versionToProvide;
	Tcl_NRAddCallback(interp, SelectPackageFinal, reqPtr, INT2PTR(reqc), (void *)reqv, data[3]);
	Tcl_NREvalObj(interp, Tcl_NewStringObj(bestPtr->script, -1), TCL_EVAL_GLOBAL);

    }
    return TCL_OK;
}
 
static int
SelectPackageFinal(ClientData data[], Tcl_Interp *interp, int result) {
    Require *reqPtr = data[0];
    int reqc = PTR2INT(data[1]);
    Tcl_Obj **const reqv = data[2];
    const char *name = reqPtr->name;
    char *versionToProvide = reqPtr->versionToProvide;

    reqPtr->pkgPtr = FindPackage(interp, name);
    if (result == TCL_OK) {
	Tcl_ResetResult(interp);
	if (reqPtr->pkgPtr->version == NULL) {
	    result = TCL_ERROR;
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "attempt to provide package %s %s failed:"
		    " no version of package %s provided",
		    name, versionToProvide, name));
	    Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNPROVIDED",
		    NULL);
	} else {
	    char *pvi, *vi;

	    if (CheckVersionAndConvert(interp, reqPtr->pkgPtr->version, &pvi,
		    NULL) != TCL_OK) {
		result = TCL_ERROR;
	    } else if (CheckVersionAndConvert(interp,
		    versionToProvide, &vi, NULL) != TCL_OK) {
		ckfree(pvi);
		result = TCL_ERROR;
	    } else {
		int res = CompareVersions(pvi, vi, NULL);

		ckfree(pvi);
		ckfree(vi);
		if (res != 0) {
		    result = TCL_ERROR;
		    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			    "attempt to provide package %s %s failed:"
			    " package %s %s provided instead",
			    name, versionToProvide,
			    name, reqPtr->pkgPtr->version));
		    Tcl_SetErrorCode(interp, "TCL", "PACKAGE",
			    "WRONGPROVIDE", NULL);
		}
	    }
	}
    } else if (result != TCL_ERROR) {
	Tcl_Obj *codePtr = Tcl_NewIntObj(result);

	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"attempt to provide package %s %s failed:"
		" bad return code: %s",
		name, versionToProvide, TclGetString(codePtr)));
	Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL);
	TclDecrRefCount(codePtr);
	result = TCL_ERROR;
    }

    if (result == TCL_ERROR) {
	Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
		"\n    (\"package ifneeded %s %s\" script)",
		name, versionToProvide));
    }
    Tcl_Release(versionToProvide);

    if (result != TCL_OK) {
	/*
	 * Take a non-TCL_OK code from the script as an indication the
	 * package wasn't loaded properly, so the package system
	 * should not remember an improper load.
	 *
	 * This is consistent with our returning NULL. If we're not
	 * willing to tell our caller we got a particular version, we
	 * shouldn't store that version for telling future callers
	 * either.
	 */

	if (reqPtr->pkgPtr->version != NULL) {
	    ckfree(reqPtr->pkgPtr->version);
	    reqPtr->pkgPtr->version = NULL;
	}
	reqPtr->pkgPtr->clientData = NULL;
	return result;
    }

    Tcl_NRAddCallback(interp, data[3], reqPtr, INT2PTR(reqc), (void *)reqv, NULL);
    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_PkgPresent / Tcl_PkgPresentEx --
................................................................................
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */
int
Tcl_PackageObjCmd(
    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    return Tcl_NRCallObjProc(interp, TclNRPackageObjCmd, NULL, objc, objv);
}

	/* ARGSUSED */
int
TclNRPackageObjCmd(
    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    static const char *const pkgOptions[] = {
	"forget",  "ifneeded", "names",   "prefer",   "present",
................................................................................
    };
    enum pkgOptions {
	PKG_FORGET,  PKG_IFNEEDED, PKG_NAMES,   PKG_PREFER,   PKG_PRESENT,
	PKG_PROVIDE, PKG_REQUIRE,  PKG_UNKNOWN, PKG_VCOMPARE, PKG_VERSIONS,
	PKG_VSATISFIES
    };
    Interp *iPtr = (Interp *) interp;
    int optionIndex, exact, i, newobjc, satisfies;
    PkgAvail *availPtr, *prevPtr;
    Package *pkgPtr;
    Tcl_HashEntry *hPtr;
    Tcl_HashSearch search;
    Tcl_HashTable *tablePtr;
    const char *version;
    const char *argv2, *argv3, *argv4;
    char *iva = NULL, *ivb = NULL;
    Tcl_Obj *objvListPtr, **newObjvPtr;

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
	return TCL_ERROR;
    }

    if (Tcl_GetIndexFromObj(interp, objv[1], pkgOptions, "option", 0,
................................................................................
	}

	version = NULL;

	argv2 = TclGetString(objv[2]);
	if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) {
	    Tcl_Obj *ov;


	    if (objc != 5) {
		goto requireSyntax;
	    }

	    version = TclGetString(objv[4]);
	    if (CheckVersionAndConvert(interp, version, NULL,
................................................................................
	    }

	    /*
	     * Create a new-style requirement for the exact version.
	     */

	    ov = Tcl_NewStringObj(version, -1);
	    Tcl_IncrRefCount(ov);
	    Tcl_AppendStringsToObj(ov, "-", version, NULL);
	    version = NULL;
	    argv3 = TclGetString(objv[3]);
	    Tcl_IncrRefCount(objv[3]);

	    objvListPtr = Tcl_NewListObj(0, NULL);
	    Tcl_IncrRefCount(objvListPtr);


	    Tcl_ListObjAppendElement(interp, objvListPtr, ov);
	    Tcl_ListObjGetElements(interp, objvListPtr, &newobjc, &newObjvPtr);

	    Tcl_NRAddCallback(interp, TclNRPackageObjCmdCleanup, objv[3], objvListPtr, NULL, NULL);
	    Tcl_NRAddCallback(interp, PkgRequireCore, (void *)argv3, INT2PTR(newobjc), newObjvPtr, NULL);
	    return TCL_OK;
	} else {
	    int i, newobjc = objc-3;
	    Tcl_Obj *const *newobjv = objv + 3;
	    if (CheckAllRequirements(interp, objc-3, objv+3) != TCL_OK) {
		return TCL_ERROR;
	    }
	    objvListPtr = Tcl_NewListObj(0, NULL);
	    Tcl_IncrRefCount(objvListPtr);
	    Tcl_IncrRefCount(objv[2]);
	    for (i = 0; i < newobjc; i++) {


		/*
		 * Tcl_Obj structures may have come from another interpreter,
		 * so duplicate them.
		 */

		Tcl_ListObjAppendElement(interp, objvListPtr, Tcl_DuplicateObj(newobjv[i]));
	    }
	    Tcl_ListObjGetElements(interp, objvListPtr, &newobjc, &newObjvPtr);
	    Tcl_NRAddCallback(interp, TclNRPackageObjCmdCleanup, objv[2], objvListPtr, NULL, NULL);
	    Tcl_NRAddCallback(interp, PkgRequireCore, (void *)argv2, INT2PTR(newobjc), newObjvPtr, NULL);
	    return TCL_OK;
	}
	break;
    case PKG_UNKNOWN: {
	int length;

	if (objc == 2) {
	    if (iPtr->packageUnknown != NULL) {
................................................................................
	break;
    }
    default:
	Tcl_Panic("Tcl_PackageObjCmd: bad option index to pkgOptions");
    }
    return TCL_OK;
}

static int
TclNRPackageObjCmdCleanup(ClientData data[], Tcl_Interp *interp, int result) {
    TclDecrRefCount((Tcl_Obj *)data[0]);
    TclDecrRefCount((Tcl_Obj *)data[1]);
    return result;
}
 
/*
 *----------------------------------------------------------------------
 *
 * FindPackage --
 *
 *	This function finds the Package record for a particular package in a

Changes to tests/package.test.

604
605
606
607
608
609
610












611
612
613
614
615
616
617
    foreach i {1.2b1 1.1} {
        package ifneeded t $i "set x $i; package provide t $i"
    }
    set x xxx
    package require t
    set x
} {1.1}














test package-4.1 {Tcl_PackageCmd procedure} -returnCodes error -body {
    package
} -result {wrong # args: should be "package option ?arg ...?"}
test package-4.2 {Tcl_PackageCmd procedure, "forget" option} {
    package forget {*}[package names]







>
>
>
>
>
>
>
>
>
>
>
>







604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
    foreach i {1.2b1 1.1} {
        package ifneeded t $i "set x $i; package provide t $i"
    }
    set x xxx
    package require t
    set x
} {1.1}
test package-3.54 {Tcl_PkgRequire procedure, coroutine support} -setup {
    package forget t
} -body {
    coroutine coro1 apply {{} {
	package ifneeded t 2.1 {
	    yield 
	    package provide t 2.1
	}
	package require t 2.1
    }}
    list [catch {coro1} msg] $msg
} -match glob -result {0 2.1} 


test package-4.1 {Tcl_PackageCmd procedure} -returnCodes error -body {
    package
} -result {wrong # args: should be "package option ?arg ...?"}
test package-4.2 {Tcl_PackageCmd procedure, "forget" option} {
    package forget {*}[package names]