win32/ipenv.c

   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:
  21         char            w32_perllib_root[MAX_PATH+1];
  22         HANDLE          w32_perldll_handle;
  23         CPerlObj        *pPerl;
  24 };
  25
  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
  73 char *CPerlEnv::Getenv(const char *varname, int &err)
  74 {
  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;
  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)
  97                       : (HINSTANCE)w32_perldll_handle,
  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