/[dtapublic]/projs/ets/trunk/src/c_tcl_base_7_5_w_mods/tclwinload.c
ViewVC logotype

Diff of /projs/ets/trunk/src/c_tcl_base_7_5_w_mods/tclwinload.c

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 67 by dashley, Mon Oct 31 00:57:34 2016 UTC revision 71 by dashley, Sat Nov 5 11:07:06 2016 UTC
# Line 1  Line 1 
1  /* $Header$ */  /* $Header$ */
2  /*  /*
3   * tclWinLoad.c --   * tclWinLoad.c --
4   *   *
5   *      This procedure provides a version of the TclLoadFile that   *      This procedure provides a version of the TclLoadFile that
6   *      works with the Windows "LoadLibrary" and "GetProcAddress"   *      works with the Windows "LoadLibrary" and "GetProcAddress"
7   *      API for dynamic loading.   *      API for dynamic loading.
8   *   *
9   * Copyright (c) 1995-1997 Sun Microsystems, Inc.   * Copyright (c) 1995-1997 Sun Microsystems, Inc.
10   *   *
11   * See the file "license.terms" for information on usage and redistribution   * See the file "license.terms" for information on usage and redistribution
12   * of this file, and for a DISCLAIMER OF ALL WARRANTIES.   * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
13   *   *
14   * RCS: @(#) $Id: tclwinload.c,v 1.1.1.1 2001/06/13 04:49:20 dtashley Exp $   * RCS: @(#) $Id: tclwinload.c,v 1.1.1.1 2001/06/13 04:49:20 dtashley Exp $
15   */   */
16    
17  #include "tclWinInt.h"  #include "tclWinInt.h"
18    
19    
20  /*  /*
21   *----------------------------------------------------------------------   *----------------------------------------------------------------------
22   *   *
23   * TclpLoadFile --   * TclpLoadFile --
24   *   *
25   *      Dynamically loads a binary code file into memory and returns   *      Dynamically loads a binary code file into memory and returns
26   *      the addresses of two procedures within that file, if they   *      the addresses of two procedures within that file, if they
27   *      are defined.   *      are defined.
28   *   *
29   * Results:   * Results:
30   *      A standard Tcl completion code.  If an error occurs, an error   *      A standard Tcl completion code.  If an error occurs, an error
31   *      message is left in the interp's result.   *      message is left in the interp's result.
32   *   *
33   * Side effects:   * Side effects:
34   *      New code suddenly appears in memory.   *      New code suddenly appears in memory.
35   *   *
36   *----------------------------------------------------------------------   *----------------------------------------------------------------------
37   */   */
38    
39  int  int
40  TclpLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr, clientDataPtr)  TclpLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr, clientDataPtr)
41      Tcl_Interp *interp;         /* Used for error reporting. */      Tcl_Interp *interp;         /* Used for error reporting. */
42      char *fileName;             /* Name of the file containing the desired      char *fileName;             /* Name of the file containing the desired
43                                   * code. */                                   * code. */
44      char *sym1, *sym2;          /* Names of two procedures to look up in      char *sym1, *sym2;          /* Names of two procedures to look up in
45                                   * the file's symbol table. */                                   * the file's symbol table. */
46      Tcl_PackageInitProc **proc1Ptr, **proc2Ptr;      Tcl_PackageInitProc **proc1Ptr, **proc2Ptr;
47                                  /* Where to return the addresses corresponding                                  /* Where to return the addresses corresponding
48                                   * to sym1 and sym2. */                                   * to sym1 and sym2. */
49      ClientData *clientDataPtr;  /* Filled with token for dynamically loaded      ClientData *clientDataPtr;  /* Filled with token for dynamically loaded
50                                   * file which will be passed back to                                   * file which will be passed back to
51                                   * TclpUnloadFile() to unload the file. */                                   * TclpUnloadFile() to unload the file. */
52  {  {
53      HINSTANCE handle;      HINSTANCE handle;
54      TCHAR *nativeName;      TCHAR *nativeName;
55      Tcl_DString ds;      Tcl_DString ds;
56    
57      nativeName = Tcl_WinUtfToTChar(fileName, -1, &ds);      nativeName = Tcl_WinUtfToTChar(fileName, -1, &ds);
58      handle = (*tclWinProcs->loadLibraryProc)(nativeName);      handle = (*tclWinProcs->loadLibraryProc)(nativeName);
59      Tcl_DStringFree(&ds);      Tcl_DStringFree(&ds);
60    
61      *clientDataPtr = (ClientData) handle;      *clientDataPtr = (ClientData) handle;
62            
63      if (handle == NULL) {      if (handle == NULL) {
64          DWORD lastError = GetLastError();          DWORD lastError = GetLastError();
65  #if 0  #if 0
66          /*          /*
67           * It would be ideal if the FormatMessage stuff worked better,           * It would be ideal if the FormatMessage stuff worked better,
68           * but unfortunately it doesn't seem to want to...           * but unfortunately it doesn't seem to want to...
69           */           */
70          LPTSTR lpMsgBuf;          LPTSTR lpMsgBuf;
71          char *buf;          char *buf;
72          int size;          int size;
73          size = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM |          size = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM |
74                  FORMAT_MESSAGE_ALLOCATE_BUFFER, NULL, lastError, 0,                  FORMAT_MESSAGE_ALLOCATE_BUFFER, NULL, lastError, 0,
75                  (LPTSTR) &lpMsgBuf, 0, NULL);                  (LPTSTR) &lpMsgBuf, 0, NULL);
76          buf = (char *) ckalloc((unsigned) TCL_INTEGER_SPACE + size + 1);          buf = (char *) ckalloc((unsigned) TCL_INTEGER_SPACE + size + 1);
77          sprintf(buf, "%d %s", lastError, (char *)lpMsgBuf);          sprintf(buf, "%d %s", lastError, (char *)lpMsgBuf);
78  #endif  #endif
79          Tcl_AppendResult(interp, "couldn't load library \"",          Tcl_AppendResult(interp, "couldn't load library \"",
80                  fileName, "\": ", (char *) NULL);                  fileName, "\": ", (char *) NULL);
81          /*          /*
82           * Check for possible DLL errors.  This doesn't work quite right,           * Check for possible DLL errors.  This doesn't work quite right,
83           * because Windows seems to only return ERROR_MOD_NOT_FOUND for           * because Windows seems to only return ERROR_MOD_NOT_FOUND for
84           * just about any problem, but it's better than nothing.  It'd be           * just about any problem, but it's better than nothing.  It'd be
85           * even better if there was a way to get what DLLs           * even better if there was a way to get what DLLs
86           */           */
87          switch (lastError) {          switch (lastError) {
88              case ERROR_MOD_NOT_FOUND:              case ERROR_MOD_NOT_FOUND:
89              case ERROR_DLL_NOT_FOUND:              case ERROR_DLL_NOT_FOUND:
90                  Tcl_AppendResult(interp, "this library or a dependent library",                  Tcl_AppendResult(interp, "this library or a dependent library",
91                          " could not be found in library path", (char *)                          " could not be found in library path", (char *)
92                          NULL);                          NULL);
93                  break;                  break;
94              case ERROR_INVALID_DLL:              case ERROR_INVALID_DLL:
95                  Tcl_AppendResult(interp, "this library or a dependent library",                  Tcl_AppendResult(interp, "this library or a dependent library",
96                          " is damaged", (char *) NULL);                          " is damaged", (char *) NULL);
97                  break;                  break;
98              case ERROR_DLL_INIT_FAILED:              case ERROR_DLL_INIT_FAILED:
99                  Tcl_AppendResult(interp, "the library initialization",                  Tcl_AppendResult(interp, "the library initialization",
100                          " routine failed", (char *) NULL);                          " routine failed", (char *) NULL);
101                  break;                  break;
102              default:              default:
103                  TclWinConvertError(lastError);                  TclWinConvertError(lastError);
104                  Tcl_AppendResult(interp, Tcl_PosixError(interp),                  Tcl_AppendResult(interp, Tcl_PosixError(interp),
105                          (char *) NULL);                          (char *) NULL);
106          }          }
107          return TCL_ERROR;          return TCL_ERROR;
108      }      }
109    
110      /*      /*
111       * For each symbol, check for both Symbol and _Symbol, since Borland       * For each symbol, check for both Symbol and _Symbol, since Borland
112       * generates C symbols with a leading '_' by default.       * generates C symbols with a leading '_' by default.
113       */       */
114    
115      *proc1Ptr = (Tcl_PackageInitProc *) GetProcAddress(handle, sym1);      *proc1Ptr = (Tcl_PackageInitProc *) GetProcAddress(handle, sym1);
116      if (*proc1Ptr == NULL) {      if (*proc1Ptr == NULL) {
117          Tcl_DStringAppend(&ds, "_", 1);          Tcl_DStringAppend(&ds, "_", 1);
118          sym1 = Tcl_DStringAppend(&ds, sym1, -1);          sym1 = Tcl_DStringAppend(&ds, sym1, -1);
119          *proc1Ptr = (Tcl_PackageInitProc *) GetProcAddress(handle, sym1);          *proc1Ptr = (Tcl_PackageInitProc *) GetProcAddress(handle, sym1);
120          Tcl_DStringFree(&ds);          Tcl_DStringFree(&ds);
121      }      }
122            
123      *proc2Ptr = (Tcl_PackageInitProc *) GetProcAddress(handle, sym2);      *proc2Ptr = (Tcl_PackageInitProc *) GetProcAddress(handle, sym2);
124      if (*proc2Ptr == NULL) {      if (*proc2Ptr == NULL) {
125          Tcl_DStringAppend(&ds, "_", 1);          Tcl_DStringAppend(&ds, "_", 1);
126          sym2 = Tcl_DStringAppend(&ds, sym2, -1);          sym2 = Tcl_DStringAppend(&ds, sym2, -1);
127          *proc2Ptr = (Tcl_PackageInitProc *) GetProcAddress(handle, sym2);          *proc2Ptr = (Tcl_PackageInitProc *) GetProcAddress(handle, sym2);
128          Tcl_DStringFree(&ds);          Tcl_DStringFree(&ds);
129      }      }
130      return TCL_OK;      return TCL_OK;
131  }  }
132    
133  /*  /*
134   *----------------------------------------------------------------------   *----------------------------------------------------------------------
135   *   *
136   * TclpUnloadFile --   * TclpUnloadFile --
137   *   *
138   *      Unloads a dynamically loaded binary code file from memory.   *      Unloads a dynamically loaded binary code file from memory.
139   *      Code pointers in the formerly loaded file are no longer valid   *      Code pointers in the formerly loaded file are no longer valid
140   *      after calling this function.   *      after calling this function.
141   *   *
142   * Results:   * Results:
143   *      None.   *      None.
144   *   *
145   * Side effects:   * Side effects:
146   *      Code removed from memory.   *      Code removed from memory.
147   *   *
148   *----------------------------------------------------------------------   *----------------------------------------------------------------------
149   */   */
150    
151  void  void
152  TclpUnloadFile(clientData)  TclpUnloadFile(clientData)
153      ClientData clientData;      /* ClientData returned by a previous call      ClientData clientData;      /* ClientData returned by a previous call
154                                   * to TclpLoadFile().  The clientData is                                   * to TclpLoadFile().  The clientData is
155                                   * a token that represents the loaded                                   * a token that represents the loaded
156                                   * file. */                                   * file. */
157  {  {
158      HINSTANCE handle;      HINSTANCE handle;
159    
160      handle = (HINSTANCE) clientData;      handle = (HINSTANCE) clientData;
161      FreeLibrary(handle);      FreeLibrary(handle);
162  }  }
163    
164  /*  /*
165   *----------------------------------------------------------------------   *----------------------------------------------------------------------
166   *   *
167   * TclGuessPackageName --   * TclGuessPackageName --
168   *   *
169   *      If the "load" command is invoked without providing a package   *      If the "load" command is invoked without providing a package
170   *      name, this procedure is invoked to try to figure it out.   *      name, this procedure is invoked to try to figure it out.
171   *   *
172   * Results:   * Results:
173   *      Always returns 0 to indicate that we couldn't figure out a   *      Always returns 0 to indicate that we couldn't figure out a
174   *      package name;  generic code will then try to guess the package   *      package name;  generic code will then try to guess the package
175   *      from the file name.  A return value of 1 would have meant that   *      from the file name.  A return value of 1 would have meant that
176   *      we figured out the package name and put it in bufPtr.   *      we figured out the package name and put it in bufPtr.
177   *   *
178   * Side effects:   * Side effects:
179   *      None.   *      None.
180   *   *
181   *----------------------------------------------------------------------   *----------------------------------------------------------------------
182   */   */
183    
184  int  int
185  TclGuessPackageName(fileName, bufPtr)  TclGuessPackageName(fileName, bufPtr)
186      char *fileName;             /* Name of file containing package (already      char *fileName;             /* Name of file containing package (already
187                                   * translated to local form if needed). */                                   * translated to local form if needed). */
188      Tcl_DString *bufPtr;        /* Initialized empty dstring.  Append      Tcl_DString *bufPtr;        /* Initialized empty dstring.  Append
189                                   * package name to this if possible. */                                   * package name to this if possible. */
190  {  {
191      return 0;      return 0;
192  }  }
193    
194  /* End of tclwinload.c */  /* End of tclwinload.c */
Legend:
Removed from v.67  
changed lines
  Added in v.71
dashley@gmail.com
 ViewVC Help
Powered by ViewVC 1.1.25