4 Interface for perl environment functions
11 class CPerlEnv : public IPerlEnv
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, ...);
19 inline void SetPerlObj(CPerlObj *p) { pPerl = p; };
21 char w32_perllib_root[MAX_PATH+1];
22 HANDLE w32_perldll_handle;
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
30 DWORD type, dwDataLen = *lpdwDataLen;
31 const char *subkey = "Software\\Perl";
32 char szBuffer[MAX_PATH+1];
35 retval = RegOpenKeyEx(hkey, subkey, 0, KEY_READ, &handle);
36 if(retval == ERROR_SUCCESS)
38 retval = RegQueryValueEx(handle, lpszValueName, 0, &type, (LPBYTE)lpszData, &dwDataLen);
40 if(retval == ERROR_SUCCESS && (type == REG_SZ || type == REG_EXPAND_SZ))
42 if(type != REG_EXPAND_SZ)
44 *lpdwDataLen = dwDataLen;
47 strcpy(szBuffer, lpszData);
48 dwDataLen = ExpandEnvironmentStrings(szBuffer, lpszData, *lpdwDataLen);
49 if(dwDataLen < *lpdwDataLen)
51 *lpdwDataLen = dwDataLen;
57 strcpy(lpszData, lpszDefault);
61 char* GetRegStr(const char *lpszValueName, char *lpszDefault, char *lpszData, unsigned long *lpdwDataLen)
63 if(!GetRegStr(HKEY_CURRENT_USER, lpszValueName, lpszDefault, lpszData, lpdwDataLen))
65 GetRegStr(HKEY_LOCAL_MACHINE, lpszValueName, lpszDefault, lpszData, lpdwDataLen);
73 char *CPerlEnv::Getenv(const char *varname, int &err)
75 char* ptr = getenv(varname);
78 unsigned long dwDataLen = sizeof(w32_perllib_root);
79 if(strcmp("PERL5DB", varname) == 0)
80 ptr = GetRegStr(varname, "", w32_perllib_root, &dwDataLen);
85 int CPerlEnv::Putenv(const char *envstring, int &err)
87 return _putenv(envstring);
90 char* CPerlEnv::LibPath(char *sfx, ...)
95 GetModuleFileName((w32_perldll_handle == INVALID_HANDLE_VALUE)
96 ? GetModuleHandle(NULL)
97 : (HINSTANCE)w32_perldll_handle,
99 sizeof(w32_perllib_root));
100 *(end = strrchr(w32_perllib_root, '\\')) = '\0';
101 if (stricmp(end-4,"\\bin") == 0)
108 sfx = va_arg(ap,char *);
111 return (w32_perllib_root);