experimental implementation of FRQ-3579001

4 files changed, 80 insertions, 28 deletions

diff --git a/generic/tclLoad.c b/generic/tclLoad.c
index 3fead6f..f8186d5 100644
--- a/generic/tclLoad.c
+++ b/generic/tclLoad.c
@@ -132,15 +132,41 @@ Tcl_LoadObjCmd(
     Tcl_LoadHandle loadHandle;
     Tcl_UniChar ch;
     unsigned len;
+    int index, flags = 0;
+    Tcl_Obj *const *savedobjv = objv;
+    static const char *const options[] = {
+	"-global",		"-lazy",	NULL
+    };
+    enum options {
+	LOAD_GLOBAL,	LOAD_LAZY
+    };
 
+    while (objc > 2) {
+	if (TclGetString(objv[2])[0] != '-') {
+	    break;
+	}
+	if (Tcl_GetIndexFromObj(interp, objv[2], options, "option", 0,
+		&index) != TCL_OK) {
+	    return TCL_ERROR;
+	}
+	++objv; --objc;
+	switch ((enum options) index) {
+	case LOAD_GLOBAL:
+	    flags |= 1;
+	    break;
+	case LOAD_LAZY:
+	    flags |= 2;
+	    break;
+	}
+    }
     if ((objc < 2) || (objc > 4)) {
-	Tcl_WrongNumArgs(interp, 1, objv, "fileName ?packageName? ?interp?");
+	Tcl_WrongNumArgs(interp, 1, savedobjv, "fileName ?-global? ?-lazy? ?packageName? ?interp?");
 	return TCL_ERROR;
     }
-    if (Tcl_FSConvertToPathType(interp, objv[1]) != TCL_OK) {
+    if (Tcl_FSConvertToPathType(interp, savedobjv[1]) != TCL_OK) {
 	return TCL_ERROR;
     }
-    fullFileName = Tcl_GetString(objv[1]);
+    fullFileName = Tcl_GetString(savedobjv[1]);
 
     Tcl_DStringInit(&pkgName);
     Tcl_DStringInit(&initName);
@@ -297,7 +323,7 @@ Tcl_LoadObjCmd(
 		 * that.
 		 */
 
-		splitPtr = Tcl_FSSplitPath(objv[1], &pElements);
+		splitPtr = Tcl_FSSplitPath(savedobjv[1], &pElements);
 		Tcl_ListObjIndex(NULL, splitPtr, pElements -1, &pkgGuessPtr);
 		pkgGuess = Tcl_GetString(pkgGuessPtr);
 		if ((pkgGuess[0] == 'l') && (pkgGuess[1] == 'i')
@@ -365,7 +391,7 @@ Tcl_LoadObjCmd(
 	symbols[1] = NULL;
 
 	Tcl_MutexLock(&packageMutex);
-	code = Tcl_LoadFile(interp, objv[1], symbols, 0, &initProc,
+	code = Tcl_LoadFile(interp, savedobjv[1], symbols, flags, &initProc,
 		&loadHandle);
 	Tcl_MutexUnlock(&packageMutex);
 	if (code != TCL_OK) {
diff --git a/tests/load.test b/tests/load.test
index 78bf64c..8bd2291 100644
--- a/tests/load.test
+++ b/tests/load.test
@@ -47,32 +47,35 @@ testConstraint testsimplefilesystem \
 
 test load-1.1 {basic errors} {} {
     list [catch {load} msg] $msg
-} "1 {wrong \# args: should be \"load fileName ?packageName? ?interp?\"}"
+} "1 {wrong \# args: should be \"load fileName ?-global? ?-lazy? ?packageName? ?interp?\"}"
 test load-1.2 {basic errors} {} {
     list [catch {load a b c d} msg] $msg
-} "1 {wrong \# args: should be \"load fileName ?packageName? ?interp?\"}"
+} "1 {wrong \# args: should be \"load fileName ?-global? ?-lazy? ?packageName? ?interp?\"}"
 test load-1.3 {basic errors} {} {
     list [catch {load a b foobar} msg] $msg
 } {1 {could not find interpreter "foobar"}}
 test load-1.4 {basic errors} {} {
-    list [catch {load {}} msg] $msg
+    list [catch {load {} -global} msg] $msg
 } {1 {must specify either file name or package name}}
 test load-1.5 {basic errors} {} {
-    list [catch {load {} {}} msg] $msg
+    list [catch {load {} -lazy {}} msg] $msg
 } {1 {must specify either file name or package name}}
 test load-1.6 {basic errors} {} {
     list [catch {load {} Unknown} msg] $msg
 } {1 {package "Unknown" isn't loaded statically}}
+test load-1.7 {basic errors} {} {
+    list [catch {load foo -abc} msg] $msg
+} "1 {bad option \"-abc\": must be -global or -lazy}"
 
 test load-2.1 {basic loading, with guess for package name} \
 	[list $dll $loaded] {
-    load [file join $testDir pkga$ext]
+    load [file join $testDir pkga$ext] -global
     list [pkga_eq abc def] [lsort [info commands pkga_*]]
 } {0 {pkga_eq pkga_quote}}
 interp create -safe child
 test load-2.2 {loading into a safe interpreter, with package name conversion} \
 	[list $dll $loaded] {
-    load [file join $testDir pkgb$ext] pKgB child
+    load [file join $testDir pkgb$ext] -lazy pKgB child
     list [child eval pkgb_sub 44 13] [catch {child eval pkgb_unsafe} msg] $msg \
 	    [catch {pkgb_sub 12 10} msg2] $msg2
 } {31 1 {invalid command name "pkgb_unsafe"} 1 {invalid command name "pkgb_sub"}}
@@ -126,7 +129,7 @@ test load-5.1 {file name not specified and no static package: pick default} \
 	[list $dll $loaded] {
     catch {interp delete x}
     interp create x
-    load [file join $testDir pkga$ext] pkga
+    load [file join $testDir pkga$ext] -global pkga
     load {} pkga x
     set result [info loaded x]
     interp delete x
diff --git a/unix/tclLoadDl.c b/unix/tclLoadDl.c
index 9ff7657..9c021e1 100644
--- a/unix/tclLoadDl.c
+++ b/unix/tclLoadDl.c
@@ -75,6 +75,7 @@ TclpDlopen(
     void *handle;
     Tcl_LoadHandle newHandle;
     const char *native;
+    int dlopenflags = 0;
 
     /*
      * First try the full path the user gave us. This is particularly
@@ -84,9 +85,19 @@ TclpDlopen(
 
     native = Tcl_FSGetNativePath(pathPtr);
     /*
-     * Use (RTLD_NOW|RTLD_LOCAL) always, see [Bug #3216070]
+     * Use (RTLD_NOW|RTLD_LOCAL) as default, see [Bug #3216070]
      */
-    handle = dlopen(native, RTLD_NOW | RTLD_LOCAL);
+    if (flags & 1) {
+    	dlopenflags |= RTLD_GLOBAL;
+    } else {
+    	dlopenflags |= RTLD_LOCAL;
+    }
+    if (flags & 2) {
+    	dlopenflags |= RTLD_LAZY;
+    } else {
+    	dlopenflags |= RTLD_NOW;
+    }
+    handle = dlopen(native, dlopenflags);
     if (handle == NULL) {
 	/*
 	 * Let the OS loader examine the binary search path for whatever
@@ -99,9 +110,9 @@ TclpDlopen(
 
 	native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds);
 	/*
-	 * Use (RTLD_NOW|RTLD_LOCAL) always, see [Bug #3216070]
+	 * Use (RTLD_NOW|RTLD_LOCAL) as default, see [Bug #3216070]
 	 */
-	handle = dlopen(native, RTLD_NOW | RTLD_LOCAL);
+	handle = dlopen(native, dlopenflags);
 	Tcl_DStringFree(&ds);
     }
 
diff --git a/unix/tclLoadDyld.c b/unix/tclLoadDyld.c
index 4f39d1f..578ce10 100644
--- a/unix/tclLoadDyld.c
+++ b/unix/tclLoadDyld.c
@@ -170,6 +170,9 @@ TclpDlopen(
     int result;
     Tcl_DString ds;
     const char *nativePath, *nativeFileName = NULL;
+#if TCL_DYLD_USE_DLFCN
+    int dlopenflags = 0;
+#endif /* TCL_DYLD_USE_DLFCN */
 
     /*
      * First try the full path the user gave us. This is particularly
@@ -183,20 +186,27 @@ TclpDlopen(
 
 #if TCL_DYLD_USE_DLFCN
     /*
-     * Use (RTLD_NOW|RTLD_LOCAL) always, see [Bug #3216070]
+     * Use (RTLD_NOW|RTLD_LOCAL) as default, see [Bug #3216070]
      */
 
-    dlHandle = dlopen(nativePath, RTLD_NOW | RTLD_LOCAL);
+    if (flags & 1) {
+    	dlopenflags |= RTLD_GLOBAL;
+    } else {
+    	dlopenflags |= RTLD_LOCAL;
+    }
+    if (flags & 2) {
+    	dlopenflags |= RTLD_LAZY;
+    } else {
+    	dlopenflags |= RTLD_NOW;
+    }
+    dlHandle = dlopen(nativePath, dlopenflags);
     if (!dlHandle) {
 	/*
 	 * Let the OS loader examine the binary search path for whatever string
 	 * the user gave us which hopefully refers to a file on the binary
 	 * path.
-	 *
-	 * Use (RTLD_NOW|RTLD_LOCAL) always, see [Bug #3216070]
-	 */
 
-	dlHandle = dlopen(nativeFileName, RTLD_NOW | RTLD_LOCAL);
+	dlHandle = dlopen(nativeFileName, dlopenflags);
 	if (!dlHandle) {
 	    errMsg = dlerror();
 	}
@@ -238,9 +248,10 @@ TclpDlopen(
 		err = NSCreateObjectFileImageFromFile(nativePath,
 			&dyldObjFileImage);
 		if (err == NSObjectFileImageSuccess && dyldObjFileImage) {
-		    module = NSLinkModule(dyldObjFileImage, nativePath,
-			    NSLINKMODULE_OPTION_BINDNOW | NSLINKMODULE_OPTION_PRIVATE
-			    | NSLINKMODULE_OPTION_RETURN_ON_ERROR);
+		    int nsflags = NSLINKMODULE_OPTION_RETURN_ON_ERROR;
+		    if (!(flags & 1)) nsflags |= NSLINKMODULE_OPTION_PRIVATE;
+		    if (!(flags & 2)) nsflags |= NSLINKMODULE_OPTION_BINDNOW;
+		    module = NSLinkModule(dyldObjFileImage, nativePath, nsflags);
 		    NSDestroyObjectFileImage(dyldObjFileImage);
 		    if (module) {
 			modulePtr = ckalloc(sizeof(Tcl_DyldModuleHandle));
@@ -565,6 +576,7 @@ TclpLoadMemory(
     Tcl_DyldModuleHandle *modulePtr;
     NSModule module;
     const char *objFileImageErrMsg = NULL;
+    int nsflags = NSLINKMODULE_OPTION_RETURN_ON_ERROR;
 
     /*
      * Try to create an object file image that we can load from.
@@ -659,9 +671,9 @@ TclpLoadMemory(
      * Extract the module we want from the image of the object file.
      */
 
-    module = NSLinkModule(dyldObjFileImage, "[Memory Based Bundle]",
-	    NSLINKMODULE_OPTION_BINDNOW | NSLINKMODULE_OPTION_PRIVATE
-	    | NSLINKMODULE_OPTION_RETURN_ON_ERROR);
+    if (!(flags & 1)) nsflags |= NSLINKMODULE_OPTION_PRIVATE;
+    if (!(flags & 2)) nsflags |= NSLINKMODULE_OPTION_BINDNOW;
+    module = NSLinkModule(dyldObjFileImage, "[Memory Based Bundle]", nsflags);
     NSDestroyObjectFileImage(dyldObjFileImage);
     if (!module) {
 	NSLinkEditErrors editError;