Commit | Line | Data |
76e3520e |
1 | /* |
2 | |
3 | ipenv.c |
4 | Interface for perl environment functions |
5 | |
6 | */ |
7 | |
8 | #include <ipenv.h> |
9 | #include <stdlib.h> |
10 | |
11 | class CPerlEnv : public IPerlEnv |
12 | { |
13 | public: |
14 | CPerlEnv() { w32_perldll_handle = INVALID_HANDLE_VALUE; pPerl = NULL; }; |
15 | virtual char *Getenv(const char *varname, int &err); |
16 | virtual int Putenv(const char *envstring, int &err); |
17 | virtual char* LibPath(char *sfx, ...); |
18 | |
19 | inline void SetPerlObj(CPerlObj *p) { pPerl = p; }; |
20 | protected: |
9d8a25dc |
21 | char w32_perllib_root[MAX_PATH+1]; |
22 | HANDLE w32_perldll_handle; |
23 | CPerlObj *pPerl; |
76e3520e |
24 | }; |
25 | |
9d8a25dc |
26 | |
27 | BOOL GetRegStr(HKEY hkey, const char *lpszValueName, char *lpszDefault, char *lpszData, unsigned long *lpdwDataLen) |
28 | { // Retrieve a REG_SZ or REG_EXPAND_SZ from the registry |
29 | HKEY handle; |
30 | DWORD type, dwDataLen = *lpdwDataLen; |
31 | const char *subkey = "Software\\Perl"; |
32 | char szBuffer[MAX_PATH+1]; |
33 | long retval; |
34 | |
35 | retval = RegOpenKeyEx(hkey, subkey, 0, KEY_READ, &handle); |
36 | if(retval == ERROR_SUCCESS) |
37 | { |
38 | retval = RegQueryValueEx(handle, lpszValueName, 0, &type, (LPBYTE)lpszData, &dwDataLen); |
39 | RegCloseKey(handle); |
40 | if(retval == ERROR_SUCCESS && (type == REG_SZ || type == REG_EXPAND_SZ)) |
41 | { |
42 | if(type != REG_EXPAND_SZ) |
43 | { |
44 | *lpdwDataLen = dwDataLen; |
45 | return TRUE; |
46 | } |
47 | strcpy(szBuffer, lpszData); |
48 | dwDataLen = ExpandEnvironmentStrings(szBuffer, lpszData, *lpdwDataLen); |
49 | if(dwDataLen < *lpdwDataLen) |
50 | { |
51 | *lpdwDataLen = dwDataLen; |
52 | return TRUE; |
53 | } |
54 | } |
55 | } |
56 | |
57 | strcpy(lpszData, lpszDefault); |
58 | return FALSE; |
59 | } |
60 | |
61 | char* GetRegStr(const char *lpszValueName, char *lpszDefault, char *lpszData, unsigned long *lpdwDataLen) |
62 | { |
63 | if(!GetRegStr(HKEY_CURRENT_USER, lpszValueName, lpszDefault, lpszData, lpdwDataLen)) |
64 | { |
65 | GetRegStr(HKEY_LOCAL_MACHINE, lpszValueName, lpszDefault, lpszData, lpdwDataLen); |
66 | } |
67 | if(*lpszData == '\0') |
68 | lpszData = NULL; |
69 | return lpszData; |
70 | } |
71 | |
72 | |
76e3520e |
73 | char *CPerlEnv::Getenv(const char *varname, int &err) |
74 | { |
9d8a25dc |
75 | char* ptr = getenv(varname); |
76 | if(ptr == NULL) |
77 | { |
78 | unsigned long dwDataLen = sizeof(w32_perllib_root); |
79 | if(strcmp("PERL5DB", varname) == 0) |
80 | ptr = GetRegStr(varname, "", w32_perllib_root, &dwDataLen); |
81 | } |
82 | return ptr; |
76e3520e |
83 | } |
84 | |
85 | int CPerlEnv::Putenv(const char *envstring, int &err) |
86 | { |
87 | return _putenv(envstring); |
88 | } |
89 | |
90 | char* CPerlEnv::LibPath(char *sfx, ...) |
91 | { |
92 | va_list ap; |
93 | char *end; |
94 | va_start(ap,sfx); |
95 | GetModuleFileName((w32_perldll_handle == INVALID_HANDLE_VALUE) |
96 | ? GetModuleHandle(NULL) |
9d8a25dc |
97 | : (HINSTANCE)w32_perldll_handle, |
76e3520e |
98 | w32_perllib_root, |
99 | sizeof(w32_perllib_root)); |
100 | *(end = strrchr(w32_perllib_root, '\\')) = '\0'; |
101 | if (stricmp(end-4,"\\bin") == 0) |
102 | end -= 4; |
103 | strcpy(end,"\\lib"); |
104 | while (sfx) |
105 | { |
106 | strcat(end,"\\"); |
107 | strcat(end,sfx); |
108 | sfx = va_arg(ap,char *); |
109 | } |
110 | va_end(ap); |
111 | return (w32_perllib_root); |
112 | } |
113 | |
114 | |
115 | |
116 | |