[p5sagit/p5-mst-13.2.git] / win32 / ipenv.c

/*

	ipenv.c
	Interface for perl environment functions

*/

#include <ipenv.h>
#include <stdlib.h>

class CPerlEnv : public IPerlEnv
{
public:
	CPerlEnv() { w32_perldll_handle = INVALID_HANDLE_VALUE; pPerl = NULL; };
	virtual char *Getenv(const char *varname, int &err);
	virtual int Putenv(const char *envstring, int &err);
	virtual char* LibPath(char *sfx, ...);

	inline void SetPerlObj(CPerlObj *p) { pPerl = p; };
protected:
	char		w32_perllib_root[MAX_PATH+1];
	HANDLE		w32_perldll_handle;
	CPerlObj	*pPerl;
};


BOOL GetRegStr(HKEY hkey, const char *lpszValueName, char *lpszDefault, char *lpszData, unsigned long *lpdwDataLen)
{	// Retrieve a REG_SZ or REG_EXPAND_SZ from the registry
	HKEY handle;
	DWORD type, dwDataLen = *lpdwDataLen;
	const char *subkey = "Software\\Perl";
	char szBuffer[MAX_PATH+1];
	long retval;

	retval = RegOpenKeyEx(hkey, subkey, 0, KEY_READ, &handle);
	if(retval == ERROR_SUCCESS) 
	{
		retval = RegQueryValueEx(handle, lpszValueName, 0, &type, (LPBYTE)lpszData, &dwDataLen);
		RegCloseKey(handle);
		if(retval == ERROR_SUCCESS && (type == REG_SZ || type == REG_EXPAND_SZ))
		{
			if(type != REG_EXPAND_SZ)
			{
				*lpdwDataLen = dwDataLen;
				return TRUE;
			}
			strcpy(szBuffer, lpszData);
			dwDataLen = ExpandEnvironmentStrings(szBuffer, lpszData, *lpdwDataLen);
			if(dwDataLen < *lpdwDataLen)
			{
				*lpdwDataLen = dwDataLen;
				return TRUE;
			}
		}
	}

	strcpy(lpszData, lpszDefault);
	return FALSE;
}

char* GetRegStr(const char *lpszValueName, char *lpszDefault, char *lpszData, unsigned long *lpdwDataLen)
{
	if(!GetRegStr(HKEY_CURRENT_USER, lpszValueName, lpszDefault, lpszData, lpdwDataLen))
	{
		GetRegStr(HKEY_LOCAL_MACHINE, lpszValueName, lpszDefault, lpszData, lpdwDataLen);
	}
	if(*lpszData == '\0')
		lpszData = NULL;
	return lpszData;
}


char *CPerlEnv::Getenv(const char *varname, int &err)
{
	char* ptr = getenv(varname);
	if(ptr == NULL)
	{
		unsigned long dwDataLen = sizeof(w32_perllib_root);
		if(strcmp("PERL5DB", varname) == 0)
			ptr = GetRegStr(varname, "", w32_perllib_root, &dwDataLen);
	}
	return ptr;
}

int CPerlEnv::Putenv(const char *envstring, int &err)
{
	return _putenv(envstring);
}

char* CPerlEnv::LibPath(char *sfx, ...)
{
    va_list ap;
    char *end;
    va_start(ap,sfx);
    GetModuleFileName((w32_perldll_handle == INVALID_HANDLE_VALUE) 
		      ? GetModuleHandle(NULL)
		      : (HINSTANCE)w32_perldll_handle,
		      w32_perllib_root, 
		      sizeof(w32_perllib_root));
    *(end = strrchr(w32_perllib_root, '\\')) = '\0';
    if (stricmp(end-4,"\\bin") == 0)
     end -= 4;
    strcpy(end,"\\lib");
    while (sfx)
     {
      strcat(end,"\\");
      strcat(end,sfx);
      sfx = va_arg(ap,char *);
     }
    va_end(ap); 
    return (w32_perllib_root);
}
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	};
76e3520e	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)
76e3520e	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