Fossil SCM

Enhance Tcl integration subsystem to check for the FOSSIL_TCL_PATH environment variable. It present, it will be used as a directory or file name where a Tcl 8.x library might be located.

mistachkin 2015-06-10 21:42 trunk
Commit b523bf0be0602c5a4a12fd3cfb0c5d3e43b56107
Parent e2411525c1fd280…
2 files changed +25 -4 +99 -30
~ src/file.c ~ src/th_tcl.c
M src/file.c
+25 -4
--- src/file.c
+++ src/file.c
@@ -57,10 +57,16 @@
5757
 i64 st_size;
5858
 i64 st_mtime;
5959
 int st_mode;
6060
 };
6161
 #endif
62
+
63
+#if defined(_WIN32) || defined(__CYGWIN__)
64
+# define fossil_isdirsep(a) (((a) == '/') || ((a) == '\\'))
65
+#else
66
+# define fossil_isdirsep(a) ((a) == '/')
67
+#endif
6268
6369
 #endif /* INTERFACE */
6470
6571
 #if !defined(_WIN32) || !(defined(__MSVCRT__) || defined(_MSC_VER))
6672
 # define fossilStat stat
@@ -370,16 +376,32 @@
370376
 ** Return the tail of a file pathname. The tail is the last component
371377
 ** of the path. For example, the tail of "/a/b/c.d" is "c.d".
372378
 */
373379
 const char *file_tail(const char *z){
374380
 const char *zTail = z;
381
+ if( !zTail ) return 0;
375382
 while( z[0] ){
376
- if( z[0]=='/' ) zTail = &z[1];
383
+ if( fossil_isdirsep(z[0]) ) zTail = &z[1];
377384
 z++;
378385
 }
379386
 return zTail;
380387
 }
388
+
389
+/*
390
+** Return the directory of a file path name. The directory is all components
391
+** except the last one. For example, the directory of "/a/b/c.d" is "/a/b".
392
+** If there is no directory, NULL is returned; otherwise, the returned memory
393
+** should be freed via fossil_free().
394
+*/
395
+char *file_dirname(const char *z){
396
+ const char *zTail = file_tail(z);
397
+ if( zTail && zTail!=z ){
398
+ return mprintf("%.*s", (int)(zTail-z-1), z);
399
+ }else{
400
+ return 0;
401
+ }
402
+}
381403
382404
 /*
383405
 ** Copy the content of a file from one place to another.
384406
 */
385407
 void file_copy(const char *zFrom, const char *zTo){
@@ -817,15 +839,14 @@
817839
 /*
818840
 ** Return true if zPath is an absolute pathname. Return false
819841
 ** if it is relative.
820842
 */
821843
 int file_is_absolute_path(const char *zPath){
822
- if( zPath[0]=='/'
844
+ if( fossil_isdirsep(zPath[0])
823845
 #if defined(_WIN32) || defined(__CYGWIN__)
824
- || zPath[0]=='\\'
825846
 || (fossil_isalpha(zPath[0]) && zPath[1]==':'
826
- && (zPath[2]=='\\' || zPath[2]=='/' || zPath[2]=='\0'))
847
+ && (fossil_isdirsep(zPath[2]) || zPath[2]=='\0'))
827848
 #endif
828849
 ){
829850
 return 1;
830851
 }else{
831852
 return 0;
832853
--- src/file.c
+++ src/file.c
@@ -57,10 +57,16 @@
57 i64 st_size;
58 i64 st_mtime;
59 int st_mode;
60 };
61 #endif
 
 
 
 
 
 
62
63 #endif /* INTERFACE */
64
65 #if !defined(_WIN32) || !(defined(__MSVCRT__) || defined(_MSC_VER))
66 # define fossilStat stat
@@ -370,16 +376,32 @@
370 ** Return the tail of a file pathname. The tail is the last component
371 ** of the path. For example, the tail of "/a/b/c.d" is "c.d".
372 */
373 const char *file_tail(const char *z){
374 const char *zTail = z;
 
375 while( z[0] ){
376 if( z[0]=='/' ) zTail = &z[1];
377 z++;
378 }
379 return zTail;
380 }
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
381
382 /*
383 ** Copy the content of a file from one place to another.
384 */
385 void file_copy(const char *zFrom, const char *zTo){
@@ -817,15 +839,14 @@
817 /*
818 ** Return true if zPath is an absolute pathname. Return false
819 ** if it is relative.
820 */
821 int file_is_absolute_path(const char *zPath){
822 if( zPath[0]=='/'
823 #if defined(_WIN32) || defined(__CYGWIN__)
824 || zPath[0]=='\\'
825 || (fossil_isalpha(zPath[0]) && zPath[1]==':'
826 && (zPath[2]=='\\' || zPath[2]=='/' || zPath[2]=='\0'))
827 #endif
828 ){
829 return 1;
830 }else{
831 return 0;
832
--- src/file.c
+++ src/file.c
@@ -57,10 +57,16 @@
57 i64 st_size;
58 i64 st_mtime;
59 int st_mode;
60 };
61 #endif
62
63 #if defined(_WIN32) || defined(__CYGWIN__)
64 # define fossil_isdirsep(a) (((a) == '/') || ((a) == '\\'))
65 #else
66 # define fossil_isdirsep(a) ((a) == '/')
67 #endif
68
69 #endif /* INTERFACE */
70
71 #if !defined(_WIN32) || !(defined(__MSVCRT__) || defined(_MSC_VER))
72 # define fossilStat stat
@@ -370,16 +376,32 @@
376 ** Return the tail of a file pathname. The tail is the last component
377 ** of the path. For example, the tail of "/a/b/c.d" is "c.d".
378 */
379 const char *file_tail(const char *z){
380 const char *zTail = z;
381 if( !zTail ) return 0;
382 while( z[0] ){
383 if( fossil_isdirsep(z[0]) ) zTail = &z[1];
384 z++;
385 }
386 return zTail;
387 }
388
389 /*
390 ** Return the directory of a file path name. The directory is all components
391 ** except the last one. For example, the directory of "/a/b/c.d" is "/a/b".
392 ** If there is no directory, NULL is returned; otherwise, the returned memory
393 ** should be freed via fossil_free().
394 */
395 char *file_dirname(const char *z){
396 const char *zTail = file_tail(z);
397 if( zTail && zTail!=z ){
398 return mprintf("%.*s", (int)(zTail-z-1), z);
399 }else{
400 return 0;
401 }
402 }
403
404 /*
405 ** Copy the content of a file from one place to another.
406 */
407 void file_copy(const char *zFrom, const char *zTo){
@@ -817,15 +839,14 @@
839 /*
840 ** Return true if zPath is an absolute pathname. Return false
841 ** if it is relative.
842 */
843 int file_is_absolute_path(const char *zPath){
844 if( fossil_isdirsep(zPath[0])
845 #if defined(_WIN32) || defined(__CYGWIN__)
 
846 || (fossil_isalpha(zPath[0]) && zPath[1]==':'
847 && (fossil_isdirsep(zPath[2]) || zPath[2]=='\0'))
848 #endif
849 ){
850 return 1;
851 }else{
852 return 0;
853
M src/th_tcl.c
+99 -30
--- src/th_tcl.c
+++ src/th_tcl.c
@@ -61,18 +61,35 @@
6161
 ** indicates whether or not we can/should use direct objProc calls.
6262
 */
6363
 #define GET_CTX_TCL_USEOBJPROC(ctx) \
6464
 ((struct TclContext *)(ctx))->useObjProc
6565
66
+/*
67
+** This is the name of an environment variable that may refer to a Tcl library
68
+** directory or file name. If this environment variable is set [to anything],
69
+** its value will be used when searching for a Tcl library to load.
70
+*/
71
+#ifndef TCL_PATH_ENV_VAR_NAME
72
+# define TCL_PATH_ENV_VAR_NAME "FOSSIL_TCL_PATH"
73
+#endif
74
+
6675
 /*
6776
 ** Define the Tcl shared library name, some exported function names, and some
6877
 ** cross-platform macros for use with the Tcl stubs mechanism, when enabled.
6978
 */
7079
 #if defined(USE_TCL_STUBS)
7180
 # if defined(_WIN32)
72
-# define WIN32_LEAN_AND_MEAN
81
+# if !defined(WIN32_LEAN_AND_MEAN)
82
+# define WIN32_LEAN_AND_MEAN
83
+# endif
84
+# if !defined(_WIN32_WINNT) || (_WIN32_WINNT < 0x0502)
85
+# define _WIN32_WINNT 0x0502 /* SetDllDirectory, Windows XP SP2 */
86
+# endif
7387
 # include <windows.h>
88
+# ifndef TCL_DIRECTORY_SEP
89
+# define TCL_DIRECTORY_SEP '\\'
90
+# endif
7491
 # ifndef TCL_LIBRARY_NAME
7592
 # define TCL_LIBRARY_NAME "tcl86.dll\0"
7693
 # endif
7794
 # ifndef TCL_MINOR_OFFSET
7895
 # define TCL_MINOR_OFFSET (4)
@@ -86,10 +103,13 @@
86103
 # ifndef dlclose
87104
 # define dlclose(a) FreeLibrary((HANDLE)(a))
88105
 # endif
89106
 # else
90107
 # include <dlfcn.h>
108
+# ifndef TCL_DIRECTORY_SEP
109
+# define TCL_DIRECTORY_SEP '/'
110
+# endif
91111
 # if defined(__CYGWIN__)
92112
 # ifndef TCL_LIBRARY_NAME
93113
 # define TCL_LIBRARY_NAME "libtcl8.6.dll\0"
94114
 # endif
95115
 # ifndef TCL_MINOR_OFFSET
@@ -123,10 +143,23 @@
123143
 # ifndef TCL_FINALIZE_NAME
124144
 # define TCL_FINALIZE_NAME "_Tcl_Finalize\0"
125145
 # endif
126146
 #endif /* defined(USE_TCL_STUBS) */
127147
148
+/*
149
+** If this constant is defined to non-zero, the Win32 SetDllDirectory function
150
+** will be used during the Tcl library loading process if the path environment
151
+** variable for Tcl was set.
152
+*/
153
+#ifndef TCL_USE_SET_DLL_DIRECTORY
154
+# if defined(_WIN32) && defined(_WIN32_WINNT) && (_WIN32_WINNT >= 0x0502)
155
+# define TCL_USE_SET_DLL_DIRECTORY (1)
156
+# else
157
+# define TCL_USE_SET_DLL_DIRECTORY (0)
158
+# endif
159
+#endif /* TCL_USE_SET_DLL_DIRECTORY */
160
+
128161
 /*
129162
 ** The function types for Tcl_FindExecutable and Tcl_CreateInterp are needed
130163
 ** when the Tcl library is being loaded dynamically by a stubs-enabled
131164
 ** application (i.e. the inverse of using a stubs-enabled package). These are
132165
 ** the only Tcl API functions that MUST be called prior to being able to call
@@ -337,11 +370,11 @@
337370
 ** copied from and should be kept in sync with the one in "main.c".
338371
 */
339372
 struct TclContext {
340373
 int argc; /* Number of original arguments. */
341374
 char **argv; /* Full copy of the original arguments. */
342
- void *library; /* The Tcl library module handle. */
375
+ void *hLibrary; /* The Tcl library module handle. */
343376
 tcl_FindExecutableProc *xFindExecutable; /* Tcl_FindExecutable() pointer. */
344377
 tcl_CreateInterpProc *xCreateInterp; /* Tcl_CreateInterp() pointer. */
345378
 tcl_DeleteInterpProc *xDeleteInterp; /* Tcl_DeleteInterp() pointer. */
346379
 tcl_FinalizeProc *xFinalize; /* Tcl_Finalize() pointer. */
347380
 Tcl_Interp *interp; /* The on-demand created Tcl interpreter. */
@@ -686,95 +719,131 @@
686719
 ** shared library and fetch the function pointers necessary to create an
687720
 ** interpreter and initialize the stubs mechanism; otherwise, simply setup
688721
 ** the function pointers provided by the caller with the statically linked
689722
 ** functions.
690723
 */
724
+char *fossil_getenv(const char *zName); /* file.h */
725
+int file_isdir(const char *zPath); /* file.h */
726
+char *file_dirname(const char *zPath); /* file.h */
727
+void fossil_free(void *p); /* util.h */
728
+
691729
 static int loadTcl(
692730
 Th_Interp *interp,
693
- void **pLibrary,
731
+ void **phLibrary,
694732
 tcl_FindExecutableProc **pxFindExecutable,
695733
 tcl_CreateInterpProc **pxCreateInterp,
696734
 tcl_DeleteInterpProc **pxDeleteInterp,
697735
 tcl_FinalizeProc **pxFinalize
698736
 ){
699737
 #if defined(USE_TCL_STUBS)
700
- char fileName[] = TCL_LIBRARY_NAME;
738
+ const char *zEnvPath = fossil_getenv(TCL_PATH_ENV_VAR_NAME);
739
+ char aFileName[] = TCL_LIBRARY_NAME;
701740
 #endif /* defined(USE_TCL_STUBS) */
702741
703
- if( !pLibrary || !pxFindExecutable || !pxCreateInterp ||
742
+ if( !phLibrary || !pxFindExecutable || !pxCreateInterp ||
704743
 !pxDeleteInterp || !pxFinalize ){
705744
 Th_ErrorMessage(interp,
706745
 "invalid Tcl loader argument(s)", (const char *)"", 0);
707746
 return TH_ERROR;
708747
 }
709748
 #if defined(USE_TCL_STUBS)
710749
 do {
711
- void *library = dlopen(fileName, RTLD_NOW | RTLD_GLOBAL);
712
- if( library ){
750
+ char *zFileName;
751
+ void *hLibrary;
752
+ if( !zEnvPath ){
753
+ zFileName = aFileName; /* NOTE: Assume present in PATH. */
754
+ }else if( file_isdir(zEnvPath)==1 ){
755
+#if TCL_USE_SET_DLL_DIRECTORY
756
+ SetDllDirectory(zEnvPath); /* NOTE: Maybe needed for "zlib1.dll". */
757
+#endif /* TCL_USE_SET_DLL_DIRECTORY */
758
+ /* NOTE: The environment variable contains a directory name. */
759
+ zFileName = sqlite3_mprintf("%s%c%s%c", zEnvPath, TCL_DIRECTORY_SEP,
760
+ aFileName, '\0');
761
+ }else{
762
+#if TCL_USE_SET_DLL_DIRECTORY
763
+ char *zDirName = file_dirname(zEnvPath);
764
+ if( zDirName ){
765
+ SetDllDirectory(zDirName); /* NOTE: Maybe needed for "zlib1.dll". */
766
+ }
767
+#endif /* TCL_USE_SET_DLL_DIRECTORY */
768
+ /* NOTE: The environment variable might contain a file name. */
769
+ zFileName = sqlite3_mprintf("%s%c", zEnvPath, '\0');
770
+#if TCL_USE_SET_DLL_DIRECTORY
771
+ if( zDirName ){
772
+ fossil_free(zDirName); zDirName = 0;
773
+ }
774
+#endif /* TCL_USE_SET_DLL_DIRECTORY */
775
+ }
776
+ hLibrary = dlopen(zFileName, RTLD_NOW | RTLD_GLOBAL);
777
+ /* NOTE: If the file name was allocated, free it now. */
778
+ if( zFileName!=aFileName ){
779
+ sqlite3_free(zFileName); zFileName = 0;
780
+ }
781
+ if( hLibrary ){
713782
 tcl_FindExecutableProc *xFindExecutable;
714783
 tcl_CreateInterpProc *xCreateInterp;
715784
 tcl_DeleteInterpProc *xDeleteInterp;
716785
 tcl_FinalizeProc *xFinalize;
717786
 const char *procName = TCL_FINDEXECUTABLE_NAME;
718
- xFindExecutable = (tcl_FindExecutableProc *)dlsym(library, procName + 1);
787
+ xFindExecutable = (tcl_FindExecutableProc *)dlsym(hLibrary, procName+1);
719788
 if( !xFindExecutable ){
720
- xFindExecutable = (tcl_FindExecutableProc *)dlsym(library, procName);
789
+ xFindExecutable = (tcl_FindExecutableProc *)dlsym(hLibrary, procName);
721790
 }
722791
 if( !xFindExecutable ){
723792
 Th_ErrorMessage(interp,
724793
 "could not locate Tcl_FindExecutable", (const char *)"", 0);
725
- dlclose(library);
794
+ dlclose(hLibrary);
726795
 return TH_ERROR;
727796
 }
728797
 procName = TCL_CREATEINTERP_NAME;
729
- xCreateInterp = (tcl_CreateInterpProc *)dlsym(library, procName + 1);
798
+ xCreateInterp = (tcl_CreateInterpProc *)dlsym(hLibrary, procName+1);
730799
 if( !xCreateInterp ){
731
- xCreateInterp = (tcl_CreateInterpProc *)dlsym(library, procName);
800
+ xCreateInterp = (tcl_CreateInterpProc *)dlsym(hLibrary, procName);
732801
 }
733802
 if( !xCreateInterp ){
734803
 Th_ErrorMessage(interp,
735804
 "could not locate Tcl_CreateInterp", (const char *)"", 0);
736
- dlclose(library);
805
+ dlclose(hLibrary);
737806
 return TH_ERROR;
738807
 }
739808
 procName = TCL_DELETEINTERP_NAME;
740
- xDeleteInterp = (tcl_DeleteInterpProc *)dlsym(library, procName + 1);
809
+ xDeleteInterp = (tcl_DeleteInterpProc *)dlsym(hLibrary, procName+1);
741810
 if( !xDeleteInterp ){
742
- xDeleteInterp = (tcl_DeleteInterpProc *)dlsym(library, procName);
811
+ xDeleteInterp = (tcl_DeleteInterpProc *)dlsym(hLibrary, procName);
743812
 }
744813
 if( !xDeleteInterp ){
745814
 Th_ErrorMessage(interp,
746815
 "could not locate Tcl_DeleteInterp", (const char *)"", 0);
747
- dlclose(library);
816
+ dlclose(hLibrary);
748817
 return TH_ERROR;
749818
 }
750819
 procName = TCL_FINALIZE_NAME;
751
- xFinalize = (tcl_FinalizeProc *)dlsym(library, procName + 1);
820
+ xFinalize = (tcl_FinalizeProc *)dlsym(hLibrary, procName+1);
752821
 if( !xFinalize ){
753
- xFinalize = (tcl_FinalizeProc *)dlsym(library, procName);
822
+ xFinalize = (tcl_FinalizeProc *)dlsym(hLibrary, procName);
754823
 }
755824
 if( !xFinalize ){
756825
 Th_ErrorMessage(interp,
757826
 "could not locate Tcl_Finalize", (const char *)"", 0);
758
- dlclose(library);
827
+ dlclose(hLibrary);
759828
 return TH_ERROR;
760829
 }
761
- *pLibrary = library;
830
+ *phLibrary = hLibrary;
762831
 *pxFindExecutable = xFindExecutable;
763832
 *pxCreateInterp = xCreateInterp;
764833
 *pxDeleteInterp = xDeleteInterp;
765834
 *pxFinalize = xFinalize;
766835
 return TH_OK;
767836
 }
768
- } while( --fileName[TCL_MINOR_OFFSET]>'3' ); /* Tcl 8.4+ */
769
- fileName[TCL_MINOR_OFFSET] = 'x';
837
+ } while( --aFileName[TCL_MINOR_OFFSET]>'3' ); /* Tcl 8.4+ */
838
+ aFileName[TCL_MINOR_OFFSET] = 'x';
770839
 Th_ErrorMessage(interp,
771840
 "could not load any supported Tcl 8.6, 8.5, or 8.4 shared library \"",
772
- fileName, -1);
841
+ aFileName, -1);
773842
 return TH_ERROR;
774843
 #else
775
- *pLibrary = 0;
844
+ *phLibrary = 0;
776845
 *pxFindExecutable = Tcl_FindExecutable;
777846
 *pxCreateInterp = Tcl_CreateInterp;
778847
 *pxDeleteInterp = Tcl_DeleteInterp;
779848
 *pxFinalize = Tcl_Finalize;
780849
 return TH_OK;
@@ -902,11 +971,11 @@
902971
 return TH_ERROR;
903972
 }
904973
 if( tclContext->interp ){
905974
 return TH_OK;
906975
 }
907
- if( loadTcl(interp, &tclContext->library, &tclContext->xFindExecutable,
976
+ if( loadTcl(interp, &tclContext->hLibrary, &tclContext->xFindExecutable,
908977
 &tclContext->xCreateInterp, &tclContext->xDeleteInterp,
909978
 &tclContext->xFinalize)!=TH_OK ){
910979
 return TH_ERROR;
911980
 }
912981
 argc = tclContext->argc;
@@ -990,11 +1059,11 @@
9901059
 ){
9911060
 struct TclContext *tclContext = (struct TclContext *)pContext;
9921061
 Tcl_Interp *tclInterp;
9931062
 tcl_FinalizeProc *xFinalize;
9941063
 #if defined(USE_TCL_STUBS)
995
- void *library;
1064
+ void *hLibrary;
9961065
 #endif /* defined(USE_TCL_STUBS) */
9971066
9981067
 if( !tclContext ){
9991068
 Th_ErrorMessage(interp,
10001069
 "invalid Tcl context", (const char *)"", 0);
@@ -1028,14 +1097,14 @@
10281097
 ** http://comments.gmane.org/gmane.comp.gnu.mingw.user/41724
10291098
 **
10301099
 ** The workaround is to manually unload the loaded Tcl library prior to
10311100
 ** exiting the process.
10321101
 */
1033
- library = tclContext->library;
1034
- if( library ){
1035
- dlclose(library);
1036
- tclContext->library = library = 0;
1102
+ hLibrary = tclContext->hLibrary;
1103
+ if( hLibrary ){
1104
+ dlclose(hLibrary);
1105
+ tclContext->hLibrary = hLibrary = 0;
10371106
 }
10381107
 #endif /* defined(USE_TCL_STUBS) */
10391108
 return TH_OK;
10401109
 }
10411110
10421111
--- src/th_tcl.c
+++ src/th_tcl.c
@@ -61,18 +61,35 @@
61 ** indicates whether or not we can/should use direct objProc calls.
62 */
63 #define GET_CTX_TCL_USEOBJPROC(ctx) \
64 ((struct TclContext *)(ctx))->useObjProc
65
 
 
 
 
 
 
 
 
 
66 /*
67 ** Define the Tcl shared library name, some exported function names, and some
68 ** cross-platform macros for use with the Tcl stubs mechanism, when enabled.
69 */
70 #if defined(USE_TCL_STUBS)
71 # if defined(_WIN32)
72 # define WIN32_LEAN_AND_MEAN
 
 
 
 
 
73 # include <windows.h>
 
 
 
74 # ifndef TCL_LIBRARY_NAME
75 # define TCL_LIBRARY_NAME "tcl86.dll\0"
76 # endif
77 # ifndef TCL_MINOR_OFFSET
78 # define TCL_MINOR_OFFSET (4)
@@ -86,10 +103,13 @@
86 # ifndef dlclose
87 # define dlclose(a) FreeLibrary((HANDLE)(a))
88 # endif
89 # else
90 # include <dlfcn.h>
 
 
 
91 # if defined(__CYGWIN__)
92 # ifndef TCL_LIBRARY_NAME
93 # define TCL_LIBRARY_NAME "libtcl8.6.dll\0"
94 # endif
95 # ifndef TCL_MINOR_OFFSET
@@ -123,10 +143,23 @@
123 # ifndef TCL_FINALIZE_NAME
124 # define TCL_FINALIZE_NAME "_Tcl_Finalize\0"
125 # endif
126 #endif /* defined(USE_TCL_STUBS) */
127
 
 
 
 
 
 
 
 
 
 
 
 
 
128 /*
129 ** The function types for Tcl_FindExecutable and Tcl_CreateInterp are needed
130 ** when the Tcl library is being loaded dynamically by a stubs-enabled
131 ** application (i.e. the inverse of using a stubs-enabled package). These are
132 ** the only Tcl API functions that MUST be called prior to being able to call
@@ -337,11 +370,11 @@
337 ** copied from and should be kept in sync with the one in "main.c".
338 */
339 struct TclContext {
340 int argc; /* Number of original arguments. */
341 char **argv; /* Full copy of the original arguments. */
342 void *library; /* The Tcl library module handle. */
343 tcl_FindExecutableProc *xFindExecutable; /* Tcl_FindExecutable() pointer. */
344 tcl_CreateInterpProc *xCreateInterp; /* Tcl_CreateInterp() pointer. */
345 tcl_DeleteInterpProc *xDeleteInterp; /* Tcl_DeleteInterp() pointer. */
346 tcl_FinalizeProc *xFinalize; /* Tcl_Finalize() pointer. */
347 Tcl_Interp *interp; /* The on-demand created Tcl interpreter. */
@@ -686,95 +719,131 @@
686 ** shared library and fetch the function pointers necessary to create an
687 ** interpreter and initialize the stubs mechanism; otherwise, simply setup
688 ** the function pointers provided by the caller with the statically linked
689 ** functions.
690 */
 
 
 
 
 
691 static int loadTcl(
692 Th_Interp *interp,
693 void **pLibrary,
694 tcl_FindExecutableProc **pxFindExecutable,
695 tcl_CreateInterpProc **pxCreateInterp,
696 tcl_DeleteInterpProc **pxDeleteInterp,
697 tcl_FinalizeProc **pxFinalize
698 ){
699 #if defined(USE_TCL_STUBS)
700 char fileName[] = TCL_LIBRARY_NAME;
 
701 #endif /* defined(USE_TCL_STUBS) */
702
703 if( !pLibrary || !pxFindExecutable || !pxCreateInterp ||
704 !pxDeleteInterp || !pxFinalize ){
705 Th_ErrorMessage(interp,
706 "invalid Tcl loader argument(s)", (const char *)"", 0);
707 return TH_ERROR;
708 }
709 #if defined(USE_TCL_STUBS)
710 do {
711 void *library = dlopen(fileName, RTLD_NOW | RTLD_GLOBAL);
712 if( library ){
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
713 tcl_FindExecutableProc *xFindExecutable;
714 tcl_CreateInterpProc *xCreateInterp;
715 tcl_DeleteInterpProc *xDeleteInterp;
716 tcl_FinalizeProc *xFinalize;
717 const char *procName = TCL_FINDEXECUTABLE_NAME;
718 xFindExecutable = (tcl_FindExecutableProc *)dlsym(library, procName + 1);
719 if( !xFindExecutable ){
720 xFindExecutable = (tcl_FindExecutableProc *)dlsym(library, procName);
721 }
722 if( !xFindExecutable ){
723 Th_ErrorMessage(interp,
724 "could not locate Tcl_FindExecutable", (const char *)"", 0);
725 dlclose(library);
726 return TH_ERROR;
727 }
728 procName = TCL_CREATEINTERP_NAME;
729 xCreateInterp = (tcl_CreateInterpProc *)dlsym(library, procName + 1);
730 if( !xCreateInterp ){
731 xCreateInterp = (tcl_CreateInterpProc *)dlsym(library, procName);
732 }
733 if( !xCreateInterp ){
734 Th_ErrorMessage(interp,
735 "could not locate Tcl_CreateInterp", (const char *)"", 0);
736 dlclose(library);
737 return TH_ERROR;
738 }
739 procName = TCL_DELETEINTERP_NAME;
740 xDeleteInterp = (tcl_DeleteInterpProc *)dlsym(library, procName + 1);
741 if( !xDeleteInterp ){
742 xDeleteInterp = (tcl_DeleteInterpProc *)dlsym(library, procName);
743 }
744 if( !xDeleteInterp ){
745 Th_ErrorMessage(interp,
746 "could not locate Tcl_DeleteInterp", (const char *)"", 0);
747 dlclose(library);
748 return TH_ERROR;
749 }
750 procName = TCL_FINALIZE_NAME;
751 xFinalize = (tcl_FinalizeProc *)dlsym(library, procName + 1);
752 if( !xFinalize ){
753 xFinalize = (tcl_FinalizeProc *)dlsym(library, procName);
754 }
755 if( !xFinalize ){
756 Th_ErrorMessage(interp,
757 "could not locate Tcl_Finalize", (const char *)"", 0);
758 dlclose(library);
759 return TH_ERROR;
760 }
761 *pLibrary = library;
762 *pxFindExecutable = xFindExecutable;
763 *pxCreateInterp = xCreateInterp;
764 *pxDeleteInterp = xDeleteInterp;
765 *pxFinalize = xFinalize;
766 return TH_OK;
767 }
768 } while( --fileName[TCL_MINOR_OFFSET]>'3' ); /* Tcl 8.4+ */
769 fileName[TCL_MINOR_OFFSET] = 'x';
770 Th_ErrorMessage(interp,
771 "could not load any supported Tcl 8.6, 8.5, or 8.4 shared library \"",
772 fileName, -1);
773 return TH_ERROR;
774 #else
775 *pLibrary = 0;
776 *pxFindExecutable = Tcl_FindExecutable;
777 *pxCreateInterp = Tcl_CreateInterp;
778 *pxDeleteInterp = Tcl_DeleteInterp;
779 *pxFinalize = Tcl_Finalize;
780 return TH_OK;
@@ -902,11 +971,11 @@
902 return TH_ERROR;
903 }
904 if( tclContext->interp ){
905 return TH_OK;
906 }
907 if( loadTcl(interp, &tclContext->library, &tclContext->xFindExecutable,
908 &tclContext->xCreateInterp, &tclContext->xDeleteInterp,
909 &tclContext->xFinalize)!=TH_OK ){
910 return TH_ERROR;
911 }
912 argc = tclContext->argc;
@@ -990,11 +1059,11 @@
990 ){
991 struct TclContext *tclContext = (struct TclContext *)pContext;
992 Tcl_Interp *tclInterp;
993 tcl_FinalizeProc *xFinalize;
994 #if defined(USE_TCL_STUBS)
995 void *library;
996 #endif /* defined(USE_TCL_STUBS) */
997
998 if( !tclContext ){
999 Th_ErrorMessage(interp,
1000 "invalid Tcl context", (const char *)"", 0);
@@ -1028,14 +1097,14 @@
1028 ** http://comments.gmane.org/gmane.comp.gnu.mingw.user/41724
1029 **
1030 ** The workaround is to manually unload the loaded Tcl library prior to
1031 ** exiting the process.
1032 */
1033 library = tclContext->library;
1034 if( library ){
1035 dlclose(library);
1036 tclContext->library = library = 0;
1037 }
1038 #endif /* defined(USE_TCL_STUBS) */
1039 return TH_OK;
1040 }
1041
1042
--- src/th_tcl.c
+++ src/th_tcl.c
@@ -61,18 +61,35 @@
61 ** indicates whether or not we can/should use direct objProc calls.
62 */
63 #define GET_CTX_TCL_USEOBJPROC(ctx) \
64 ((struct TclContext *)(ctx))->useObjProc
65
66 /*
67 ** This is the name of an environment variable that may refer to a Tcl library
68 ** directory or file name. If this environment variable is set [to anything],
69 ** its value will be used when searching for a Tcl library to load.
70 */
71 #ifndef TCL_PATH_ENV_VAR_NAME
72 # define TCL_PATH_ENV_VAR_NAME "FOSSIL_TCL_PATH"
73 #endif
74
75 /*
76 ** Define the Tcl shared library name, some exported function names, and some
77 ** cross-platform macros for use with the Tcl stubs mechanism, when enabled.
78 */
79 #if defined(USE_TCL_STUBS)
80 # if defined(_WIN32)
81 # if !defined(WIN32_LEAN_AND_MEAN)
82 # define WIN32_LEAN_AND_MEAN
83 # endif
84 # if !defined(_WIN32_WINNT) || (_WIN32_WINNT < 0x0502)
85 # define _WIN32_WINNT 0x0502 /* SetDllDirectory, Windows XP SP2 */
86 # endif
87 # include <windows.h>
88 # ifndef TCL_DIRECTORY_SEP
89 # define TCL_DIRECTORY_SEP '\\'
90 # endif
91 # ifndef TCL_LIBRARY_NAME
92 # define TCL_LIBRARY_NAME "tcl86.dll\0"
93 # endif
94 # ifndef TCL_MINOR_OFFSET
95 # define TCL_MINOR_OFFSET (4)
@@ -86,10 +103,13 @@
103 # ifndef dlclose
104 # define dlclose(a) FreeLibrary((HANDLE)(a))
105 # endif
106 # else
107 # include <dlfcn.h>
108 # ifndef TCL_DIRECTORY_SEP
109 # define TCL_DIRECTORY_SEP '/'
110 # endif
111 # if defined(__CYGWIN__)
112 # ifndef TCL_LIBRARY_NAME
113 # define TCL_LIBRARY_NAME "libtcl8.6.dll\0"
114 # endif
115 # ifndef TCL_MINOR_OFFSET
@@ -123,10 +143,23 @@
143 # ifndef TCL_FINALIZE_NAME
144 # define TCL_FINALIZE_NAME "_Tcl_Finalize\0"
145 # endif
146 #endif /* defined(USE_TCL_STUBS) */
147
148 /*
149 ** If this constant is defined to non-zero, the Win32 SetDllDirectory function
150 ** will be used during the Tcl library loading process if the path environment
151 ** variable for Tcl was set.
152 */
153 #ifndef TCL_USE_SET_DLL_DIRECTORY
154 # if defined(_WIN32) && defined(_WIN32_WINNT) && (_WIN32_WINNT >= 0x0502)
155 # define TCL_USE_SET_DLL_DIRECTORY (1)
156 # else
157 # define TCL_USE_SET_DLL_DIRECTORY (0)
158 # endif
159 #endif /* TCL_USE_SET_DLL_DIRECTORY */
160
161 /*
162 ** The function types for Tcl_FindExecutable and Tcl_CreateInterp are needed
163 ** when the Tcl library is being loaded dynamically by a stubs-enabled
164 ** application (i.e. the inverse of using a stubs-enabled package). These are
165 ** the only Tcl API functions that MUST be called prior to being able to call
@@ -337,11 +370,11 @@
370 ** copied from and should be kept in sync with the one in "main.c".
371 */
372 struct TclContext {
373 int argc; /* Number of original arguments. */
374 char **argv; /* Full copy of the original arguments. */
375 void *hLibrary; /* The Tcl library module handle. */
376 tcl_FindExecutableProc *xFindExecutable; /* Tcl_FindExecutable() pointer. */
377 tcl_CreateInterpProc *xCreateInterp; /* Tcl_CreateInterp() pointer. */
378 tcl_DeleteInterpProc *xDeleteInterp; /* Tcl_DeleteInterp() pointer. */
379 tcl_FinalizeProc *xFinalize; /* Tcl_Finalize() pointer. */
380 Tcl_Interp *interp; /* The on-demand created Tcl interpreter. */
@@ -686,95 +719,131 @@
719 ** shared library and fetch the function pointers necessary to create an
720 ** interpreter and initialize the stubs mechanism; otherwise, simply setup
721 ** the function pointers provided by the caller with the statically linked
722 ** functions.
723 */
724 char *fossil_getenv(const char *zName); /* file.h */
725 int file_isdir(const char *zPath); /* file.h */
726 char *file_dirname(const char *zPath); /* file.h */
727 void fossil_free(void *p); /* util.h */
728
729 static int loadTcl(
730 Th_Interp *interp,
731 void **phLibrary,
732 tcl_FindExecutableProc **pxFindExecutable,
733 tcl_CreateInterpProc **pxCreateInterp,
734 tcl_DeleteInterpProc **pxDeleteInterp,
735 tcl_FinalizeProc **pxFinalize
736 ){
737 #if defined(USE_TCL_STUBS)
738 const char *zEnvPath = fossil_getenv(TCL_PATH_ENV_VAR_NAME);
739 char aFileName[] = TCL_LIBRARY_NAME;
740 #endif /* defined(USE_TCL_STUBS) */
741
742 if( !phLibrary || !pxFindExecutable || !pxCreateInterp ||
743 !pxDeleteInterp || !pxFinalize ){
744 Th_ErrorMessage(interp,
745 "invalid Tcl loader argument(s)", (const char *)"", 0);
746 return TH_ERROR;
747 }
748 #if defined(USE_TCL_STUBS)
749 do {
750 char *zFileName;
751 void *hLibrary;
752 if( !zEnvPath ){
753 zFileName = aFileName; /* NOTE: Assume present in PATH. */
754 }else if( file_isdir(zEnvPath)==1 ){
755 #if TCL_USE_SET_DLL_DIRECTORY
756 SetDllDirectory(zEnvPath); /* NOTE: Maybe needed for "zlib1.dll". */
757 #endif /* TCL_USE_SET_DLL_DIRECTORY */
758 /* NOTE: The environment variable contains a directory name. */
759 zFileName = sqlite3_mprintf("%s%c%s%c", zEnvPath, TCL_DIRECTORY_SEP,
760 aFileName, '\0');
761 }else{
762 #if TCL_USE_SET_DLL_DIRECTORY
763 char *zDirName = file_dirname(zEnvPath);
764 if( zDirName ){
765 SetDllDirectory(zDirName); /* NOTE: Maybe needed for "zlib1.dll". */
766 }
767 #endif /* TCL_USE_SET_DLL_DIRECTORY */
768 /* NOTE: The environment variable might contain a file name. */
769 zFileName = sqlite3_mprintf("%s%c", zEnvPath, '\0');
770 #if TCL_USE_SET_DLL_DIRECTORY
771 if( zDirName ){
772 fossil_free(zDirName); zDirName = 0;
773 }
774 #endif /* TCL_USE_SET_DLL_DIRECTORY */
775 }
776 hLibrary = dlopen(zFileName, RTLD_NOW | RTLD_GLOBAL);
777 /* NOTE: If the file name was allocated, free it now. */
778 if( zFileName!=aFileName ){
779 sqlite3_free(zFileName); zFileName = 0;
780 }
781 if( hLibrary ){
782 tcl_FindExecutableProc *xFindExecutable;
783 tcl_CreateInterpProc *xCreateInterp;
784 tcl_DeleteInterpProc *xDeleteInterp;
785 tcl_FinalizeProc *xFinalize;
786 const char *procName = TCL_FINDEXECUTABLE_NAME;
787 xFindExecutable = (tcl_FindExecutableProc *)dlsym(hLibrary, procName+1);
788 if( !xFindExecutable ){
789 xFindExecutable = (tcl_FindExecutableProc *)dlsym(hLibrary, procName);
790 }
791 if( !xFindExecutable ){
792 Th_ErrorMessage(interp,
793 "could not locate Tcl_FindExecutable", (const char *)"", 0);
794 dlclose(hLibrary);
795 return TH_ERROR;
796 }
797 procName = TCL_CREATEINTERP_NAME;
798 xCreateInterp = (tcl_CreateInterpProc *)dlsym(hLibrary, procName+1);
799 if( !xCreateInterp ){
800 xCreateInterp = (tcl_CreateInterpProc *)dlsym(hLibrary, procName);
801 }
802 if( !xCreateInterp ){
803 Th_ErrorMessage(interp,
804 "could not locate Tcl_CreateInterp", (const char *)"", 0);
805 dlclose(hLibrary);
806 return TH_ERROR;
807 }
808 procName = TCL_DELETEINTERP_NAME;
809 xDeleteInterp = (tcl_DeleteInterpProc *)dlsym(hLibrary, procName+1);
810 if( !xDeleteInterp ){
811 xDeleteInterp = (tcl_DeleteInterpProc *)dlsym(hLibrary, procName);
812 }
813 if( !xDeleteInterp ){
814 Th_ErrorMessage(interp,
815 "could not locate Tcl_DeleteInterp", (const char *)"", 0);
816 dlclose(hLibrary);
817 return TH_ERROR;
818 }
819 procName = TCL_FINALIZE_NAME;
820 xFinalize = (tcl_FinalizeProc *)dlsym(hLibrary, procName+1);
821 if( !xFinalize ){
822 xFinalize = (tcl_FinalizeProc *)dlsym(hLibrary, procName);
823 }
824 if( !xFinalize ){
825 Th_ErrorMessage(interp,
826 "could not locate Tcl_Finalize", (const char *)"", 0);
827 dlclose(hLibrary);
828 return TH_ERROR;
829 }
830 *phLibrary = hLibrary;
831 *pxFindExecutable = xFindExecutable;
832 *pxCreateInterp = xCreateInterp;
833 *pxDeleteInterp = xDeleteInterp;
834 *pxFinalize = xFinalize;
835 return TH_OK;
836 }
837 } while( --aFileName[TCL_MINOR_OFFSET]>'3' ); /* Tcl 8.4+ */
838 aFileName[TCL_MINOR_OFFSET] = 'x';
839 Th_ErrorMessage(interp,
840 "could not load any supported Tcl 8.6, 8.5, or 8.4 shared library \"",
841 aFileName, -1);
842 return TH_ERROR;
843 #else
844 *phLibrary = 0;
845 *pxFindExecutable = Tcl_FindExecutable;
846 *pxCreateInterp = Tcl_CreateInterp;
847 *pxDeleteInterp = Tcl_DeleteInterp;
848 *pxFinalize = Tcl_Finalize;
849 return TH_OK;
@@ -902,11 +971,11 @@
971 return TH_ERROR;
972 }
973 if( tclContext->interp ){
974 return TH_OK;
975 }
976 if( loadTcl(interp, &tclContext->hLibrary, &tclContext->xFindExecutable,
977 &tclContext->xCreateInterp, &tclContext->xDeleteInterp,
978 &tclContext->xFinalize)!=TH_OK ){
979 return TH_ERROR;
980 }
981 argc = tclContext->argc;
@@ -990,11 +1059,11 @@
1059 ){
1060 struct TclContext *tclContext = (struct TclContext *)pContext;
1061 Tcl_Interp *tclInterp;
1062 tcl_FinalizeProc *xFinalize;
1063 #if defined(USE_TCL_STUBS)
1064 void *hLibrary;
1065 #endif /* defined(USE_TCL_STUBS) */
1066
1067 if( !tclContext ){
1068 Th_ErrorMessage(interp,
1069 "invalid Tcl context", (const char *)"", 0);
@@ -1028,14 +1097,14 @@
1097 ** http://comments.gmane.org/gmane.comp.gnu.mingw.user/41724
1098 **
1099 ** The workaround is to manually unload the loaded Tcl library prior to
1100 ** exiting the process.
1101 */
1102 hLibrary = tclContext->hLibrary;
1103 if( hLibrary ){
1104 dlclose(hLibrary);
1105 tclContext->hLibrary = hLibrary = 0;
1106 }
1107 #endif /* defined(USE_TCL_STUBS) */
1108 return TH_OK;
1109 }
1110
1111

Keyboard Shortcuts

Open search /
Next entry (timeline) j
Previous entry (timeline) k
Open focused entry Enter
Show this help ?
Toggle theme Top nav button