DN510119010

Subject: Re: Cross platform loading / linking mechanism. (was Re: Extension Installation and Tcl Bug) - DN [1]

davygrvy@bigfoot.com (David Gravereaux) - 08 Aug 1999 - comp.lang.tcl

 ----=_37ace593772404889052a4179.MFSBCHJLHS
 Content-Type: text/plain; charset=us-ascii
 Content-Transfer-Encoding: 7bit

 Paul,

 Here's the logic as far as I can see through my "rosey" WIN32 goggles
 :)

 How's this look so far?

 tclWinDlLoad.c gets dropped in tcl8.2b1/win/.  That's an edit on Jan's
 dlopen() routines he posted on c.l.t back in May and could be extended
 to cross-over into TclpLoadFile.

 * David Gravereaux *
 Tomahawk Software Group

 ----=_37ace593772404889052a4179.MFSBCHJLHS
 Content-Type: text/plain; charset=us-ascii; name=main.c
 Content-Transfer-Encoding: 7bit
 Content-Disposition: attachment; filename=main.c

 #include <stdlib.h>
 #include <string.h>

 #define _TCLDECLS  /* lets make sure we don't touch ANY Tcl library functions */
 #include "e:/TclCVS/tcl8.2b1/generic/tclPort.h"
 #include "e:/TclCVS/tcl8.2b1/compat/dlfcn.h"

 #ifdef _WIN32
 char *prefix = "\\bin\\tcl";
 #endif

 char *sharedlibextension = TCL_SHLIB_EXT;
 char *tclvers[] = { "8.4", "8.3", "8.2", "8.1", NULL };

 VOID *stubTclLibHnd;
 char *stubLoadErrorMsg;

 static VOID stubBuildTrailing(pos, ver, dbgOnly)
   char *pos;
   char *ver;
   int dbgOnly;
 {
  char *pos2;

   /* append version w/o decimal */
   pos2 = ver;
   while (*pos2 != '\0') {
     if (*pos2 != '.') *pos++ = *pos2++;
     else pos2++;
   };

   /* if asked, add the debug suffix */
   if (dbgOnly != 0) *pos++ = 'd';

   /* append the extension */
   pos2 = sharedlibextension;
   while (*pos2 != '\0') {
     *pos++ = *pos2++;
   };

   /* terminate it */
   *pos = '\0';
 };

 char *Stub_LoadTcl (minVer, exact, dbgOnly)
   char *minVer;
   int exact;
   int dbgOnly;
 {
  char *tclRootPath = NULL;
  char tcllibfullpath[_MAX_PATH];
  char *savedPos;
  char *pos, *pos2;
 #ifdef _WIN32
  HKEY topTclKey;
  HKEY subTclVer;
  DWORD max_path = _MAX_PATH;
  LONG result;
 #endif

   /* Try the environment variable first.  This overrides everything. */
   tclRootPath = getenv("TCL_LIBRARY_PATH");
   if (tclRootPath != NULL) {

     pos = tcllibfullpath;
     while (*tclRootPath != '\0') {
       *pos++ = *tclRootPath++;
     };

     /* append the bin directory and prefix */
     pos2 = prefix;
     while (*pos2 != '\0') {
       *pos++ = *pos2++;
     };
     savedPos = pos;

     if (exact != 0) {

       /* build the end of the filename from the parameter given */
       stubBuildTrailing(savedPos, minVer, dbgOnly);

       /* Try it */
       if ((stubTclLibHnd = dlopen(tcllibfullpath, RTLD_NOW)) != NULL)
           return minVer;

       /*  Not successfull, save error */
       //stubLoadErrorMsg = dlerror();
       //return NULL;

     } else {
      int i = 0;

       /* Try a range of filenames starting at the top and working down */
       while (tclvers[i] != NULL && strcmp(tclvers[i],minVer) >= 0) {
         /* build the end of the filename */
         stubBuildTrailing(savedPos, tclvers[i], dbgOnly);
         /* Try it */
         if ((stubTclLibHnd = dlopen(tcllibfullpath, RTLD_NOW)) != NULL)
             return tclvers[i];
         i++;
       };
     }

     /*
      * A suitable Tcl library hasn't been found yet.
      * Keep falling through.
      */
   }

 #ifdef _WIN32

     result = RegOpenKeyEx(
         HKEY_LOCAL_MACHINE, "SOFTWARE\\Scriptics\\Tcl", 0,
         KEY_ENUMERATE_SUB_KEYS, &topTclKey
         );

     if (result != ERROR_SUCCESS) {
       /* do some error thing here. */
       goto Next;
     };

     if (exact != 0) {
       /* Just try the requested only */
       result = RegOpenKeyEx(
           topTclKey, minVer, 0,
           KEY_READ, &subTclVer
           );

       if (result != ERROR_SUCCESS) {
         /* Subkey for exact version not found. */
         goto Next;
       };

       /* Retrieve location and load it. */
       result =
           RegQueryValueEx(subTclVer, "Root", NULL, NULL, tcllibfullpath, &max_path);

       if (result != ERROR_SUCCESS) {
         stubLoadErrorMsg = "SubKey found in registry for exact match, but no Root value set.";
         return NULL;
       };

       pos = tcllibfullpath + strlen(tcllibfullpath);

       /* append the bin directory and prefix */
       pos2 = prefix;
       while (*pos2 != '\0') {
         *pos++ = *pos2++;
       };
       savedPos = pos;

       /* build the end of the filename from the parameter given */
       stubBuildTrailing(savedPos, minVer, dbgOnly);

       /* Try it */
       if ((stubTclLibHnd = dlopen(tcllibfullpath, RTLD_NOW)) != NULL)
           return minVer;

     } else {
       /* Enumerate the subkeys starting at the top */
       int i;

       /* Try a range of filenames starting at the top and working down */
       for (i = 0; tclvers[i] != NULL && strcmp(tclvers[i],minVer) >= 0; i++) {

         result = RegOpenKeyEx(topTclKey, tclvers[i], 0, KEY_READ, &subTclVer);

         if (result != ERROR_SUCCESS) {
           continue;
         };

         /* Try it. */
         result =
             RegQueryValueEx(subTclVer, "Root", NULL, NULL, tcllibfullpath, &max_path);

         if (result != ERROR_SUCCESS) {
           /* Odd...  SubKey is there, but no Root value. */
           continue;
         };

         pos = tcllibfullpath + strlen(tcllibfullpath);

         /* append the bin directory and prefix */
         pos2 = prefix;
         while (*pos2 != '\0') {
           *pos++ = *pos2++;
         };
         savedPos = pos;

         /* build the end of the filename */
         stubBuildTrailing(savedPos, tclvers[i], dbgOnly);
         /* Try it */
         if ((stubTclLibHnd = dlopen(tcllibfullpath, RTLD_NOW)) != NULL)
             return tclvers[i];
       };

     /*
      * A suitable Tcl library hasn't been found yet.
      * Keep falling through.
      */

     };
 Next:
 #endif

   /* Try current directory.  Last chance.  You better work. */
   pos = tcllibfullpath;
   pos2 = "tcl";
   while (*pos2 != '\0') {
     *pos++ = *pos2++;
   };
   savedPos = pos;

   if (exact != 0) {
     stubBuildTrailing(savedPos, minVer, dbgOnly);

     /* Try it */
     if ((stubTclLibHnd = dlopen(tcllibfullpath, RTLD_NOW)) != NULL)
         return minVer;

   } else {
    int i;

     /* Try a range of filenames starting at the top and working down */
     for (i = 0; tclvers[i] != NULL && strcmp(tclvers[i],minVer) >= 0; i++) {
       /* build the end of the filename */
       stubBuildTrailing(savedPos, tclvers[i], dbgOnly);
       /* Try it */
       if ((stubTclLibHnd = dlopen(tcllibfullpath, RTLD_NOW)) != NULL)
           return tclvers[i];
     };
   }

   stubLoadErrorMsg = "A proper Tcl library could not be located.";
   return NULL;
 }

 VOID Stub_UnLoadTcl () {
   dlclose(stubTclLibHnd);
 };

 char *Stub_LoadTclError() {
   return stubLoadErrorMsg;
 };

 int main (int argc, char *argv[]) {
  char *verloaded;

   if ((verloaded = Stub_LoadTcl(/*minver*/"8.2", /*exact*/0, /*debug*/0)) == NULL) {
     printf("%s", Stub_LoadTclError());
     return 1;
   };

   printf("tcl v%s was loaded\n", verloaded);

   Stub_UnLoadTcl();
   return 0;
 }

 ----=_37ace593772404889052a4179.MFSBCHJLHS
 Content-Type: text/plain; charset=us-ascii; name=tclWinDlLoad.c
 Content-Transfer-Encoding: 7bit
 Content-Disposition: attachment; filename=tclWinDlLoad.c

 /*
  * tclWinDlLoad.c --
  *
  * This procedure provides a version of dlopen() that
  * works with the Windows "LoadLibrary" and "GetProcAddress"
  * API for dynamic loading.
  *
  * These routines do not contain any dependancies for the
  * Tcl library so they can be used specificly for loading one
  * in a Stub'd application.
  *
  * They could also be integrated into TclpLoadFile, should it be desired.
  *
  * code from a c.l.t post:
  * Sub: [Request Tcl 8.1] Dynamical loading enhancement for extensions
  * Date: 05/20/1999
  * Author: Jan Nijtmans <jan.nijtmans@wxs.nl>
  *
  */

 #define WIN32_LEAN_AND_MEAN
 #include <windows.h>
 #undef WIN32_LEAN_AND_MEAN

 #include "../compat/dlfcn.h"

 char WinErrorMsg[1024];

 /*
  *----------------------------------------------------------------------
  *
  * dlopen --
  *
  * This function is an alternative for the functions
  * TclWinLoadLibrary and TclWinGetTclInstance.
  *
  * Results:
  *  Returns the handle of the newly loaded library, or NULL on
  *  failure. If path is NULL, the global library instance handle
  *  is returned.
  *
  * Side effects:
  *  Loads the specified library into the process.
  *
  *----------------------------------------------------------------------
  */

 VOID *dlopen(path, mode)
    const char *path;
    int mode;
 {
    HMODULE mod;
    mod = LoadLibrary(path);
    if (mod <= (HMODULE) HINSTANCE_ERROR) return NULL;
    return (VOID *) mod;
 };

 /*
  *----------------------------------------------------------------------
  *
  * dlclose --
  *
  * This function is an alternative for the function
  * FreeLibrary.  It is responsible for removing library
  * handles from the library list and remove the dll
  * from memory.
  *
  * Results:
  *  -1 on error, 0 on success.
  *
  * Side effects:
  *  Unmaps and removes the specified library from the process.
  *
  *----------------------------------------------------------------------
  */

 int
 dlclose(handle)
    VOID *handle;
 {
   BOOL rtn;

   rtn = FreeLibrary((HMODULE) handle);
   if (rtn != 0) return 0;
   return -1;
 }

 /*
  *----------------------------------------------------------------------
  *
  * dlsym --
  *
  * This function is an alternative for the system function
  * GetProcAddress. It returns the address of a
  * symbol, give the handle returned by dlopen().
  *
  * Results:
  *  Returns the address of the symbol in the dll.
  *
  * Side effects:
  *  None.
  *
  *----------------------------------------------------------------------
  */

 VOID *dlsym(handle, symbol)
    VOID *handle;
    CONST char *symbol;
 {
    return (VOID *) GetProcAddress((HMODULE) handle, symbol);
 }

 /*
  *----------------------------------------------------------------------
  *
  * dlerror --
  *
  * This function returns a string describing the error which
  * occurred in dlopen().
  *
  * Results:
  *  Returns an error message.
  *
  * Side effects:
  *  errno is not set.
  *
  *----------------------------------------------------------------------
  */

 char *
 dlerror()
 {
   FormatMessage(
       FORMAT_MESSAGE_FROM_SYSTEM, NULL, GetLastError(),
       MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT),
       WinErrorMsg, 1024, NULL
       );

   return WinErrorMsg;
 }

 ----=_37ace593772404889052a4179.MFSBCHJLHS--