From: Gurusamy Sarathy Date: Fri, 3 Apr 1998 01:26:09 +0000 (+0000) Subject: [asperl] add AS patch#15 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=00dc2f4f23da07658d2634f904ac3a098aaa4153;p=p5sagit%2Fp5-mst-13.2.git [asperl] add AS patch#15 p4raw-id: //depot/asperl@863 --- diff --git a/ipenv.h b/ipenv.h index 76f8baa..30acffb 100644 --- a/ipenv.h +++ b/ipenv.h @@ -13,7 +13,8 @@ class IPerlEnv public: virtual char* Getenv(const char *varname, int &err) = 0; virtual int Putenv(const char *envstring, int &err) = 0; - virtual char* LibPath(char *sfx, ...) =0; + virtual char* LibPath(char *patchlevel) =0; + virtual char* SiteLibPath(char *patchlevel) =0; }; #endif /* __Inc__IPerlEnv___ */ diff --git a/lib/ExtUtils/MM_Unix.pm b/lib/ExtUtils/MM_Unix.pm index e5c4786..5faa435 100644 --- a/lib/ExtUtils/MM_Unix.pm +++ b/lib/ExtUtils/MM_Unix.pm @@ -2723,7 +2723,10 @@ sub ppd { push(@m, "ppd:\n"); push(@m, "\t\@\$(PERL) -e \"print qq{{DISTNAME}\\\" VERSION=\\\"$pack_ver\\\">\\n}"); push(@m, ". qq{\\t$self->{DISTNAME}\\n}"); - push(@m, ". qq{\\t$self->{ABSTRACT}\\n}"); + my $abstract = $self->{ABSTRACT}; + $abstract =~ s//>/g; + push(@m, ". qq{\\t$abstract\\n}"); my ($author) = $self->{AUTHOR}; $author =~ s/@/\\@/g; push(@m, ". qq{\\t$author\\n}"); diff --git a/perl.c b/perl.c index c4f1bcc..abd54b9 100644 --- a/perl.c +++ b/perl.c @@ -2691,14 +2691,22 @@ init_perllib(void) #ifndef PRIVLIB_EXP #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl" #endif +#if defined(WIN32) + incpush(PRIVLIB_EXP, TRUE); +#else incpush(PRIVLIB_EXP, FALSE); +#endif #ifdef SITEARCH_EXP incpush(SITEARCH_EXP, FALSE); #endif #ifdef SITELIB_EXP +#if defined(WIN32) + incpush(SITELIB_EXP, TRUE); +#else incpush(SITELIB_EXP, FALSE); #endif +#endif if (!tainting) incpush(".", FALSE); } diff --git a/perlenv.h b/perlenv.h index eb631a2..07cce76 100644 --- a/perlenv.h +++ b/perlenv.h @@ -5,9 +5,12 @@ #include "ipenv.h" -#define PerlEnv_putenv(str) piENV->Putenv((str), ErrorNo()) -#define PerlEnv_getenv(str) piENV->Getenv((str), ErrorNo()) -#define PerlEnv_lib_path piENV->LibPath +#define PerlEnv_putenv(str) piENV->Putenv((str), ErrorNo()) +#define PerlEnv_getenv(str) piENV->Getenv((str), ErrorNo()) +#ifdef WIN32 +#define PerlEnv_lib_path(str) piENV->LibPath((str)) +#define PerlEnv_sitelib_path(str) piENV->SiteLibPath((str)) +#endif #else #define PerlEnv_putenv(str) putenv((str)) #define PerlEnv_getenv(str) getenv((str)) diff --git a/win32/config.bc b/win32/config.bc index 365c5de..0ebcfcc 100644 --- a/win32/config.bc +++ b/win32/config.bc @@ -21,8 +21,8 @@ afs='false' alignbytes='8' aphostname='' ar='tlib /P128' -archlib='~INST_TOP~\lib\~archname~' -archlibexp='~INST_TOP~\lib\~archname~' +archlib='' +archlibexp='' archname='MSWin32' archobjs='' awk='awk' @@ -65,7 +65,7 @@ csh='undef' d_Gconvert='gcvt((x),(n),(b))' d_access='define' d_alarm='undef' -d_archlib='define' +d_archlib='undef' d_attribut='undef' d_bcmp='undef' d_bcopy='undef' @@ -346,13 +346,13 @@ i_varhdr='varargs.h' i_vfork='undef' incpath='' inews='' -installarchlib='~INST_TOP~\lib\~archname~' +installarchlib='' installbin='~INST_TOP~\bin' installman1dir='~INST_TOP~\man\man1' installman3dir='~INST_TOP~\man\man3' installprivlib='~INST_TOP~\lib' installscript='~INST_TOP~\bin' -installsitearch='~INST_TOP~\lib\site\~archname~' +installsitearch='' installsitelib='~INST_TOP~\lib\site' intsize='4' known_extensions='DB_File Fcntl GDBM_File NDBM_File ODBM_File Opcode POSIX SDBM_File Socket IO attrs Thread' @@ -462,8 +462,8 @@ sig_name='ZERO INT ILL FPE SEGV TERM USR1 USR2 USR3 BREAK ABRT' sig_name_init='"ZERO", "INT", "ILL", "FPE", "SEGV", "TERM", "USR1", "USR2", "USR3", "BREAK", "ABRT", 0' sig_num='0, 2, 4, 8, 11, 15, 16, 17, 20, 21, 22, 0' signal_t='void' -sitearch='~INST_TOP~\lib\site\~archname~' -sitearchexp='~INST_TOP~\lib\site\~archname~' +sitearch='' +sitearchexp='' sitelib='~INST_TOP~\lib\site' sitelibexp='~INST_TOP~\lib\site' sizetype='size_t' diff --git a/win32/config.gc b/win32/config.gc index 0bf2718..0e2f200 100644 --- a/win32/config.gc +++ b/win32/config.gc @@ -21,8 +21,8 @@ afs='false' alignbytes='8' aphostname='' ar='ar' -archlib='~INST_TOP~\lib\~archname~' -archlibexp='~INST_TOP~\lib\~archname~' +archlib='' +archlibexp='' archname='MSWin32' archobjs='' awk='awk' @@ -65,7 +65,7 @@ csh='undef' d_Gconvert='sprintf((b),"%.*g",(n),(x))' d_access='define' d_alarm='undef' -d_archlib='define' +d_archlib='undef' d_attribut='define' d_bcmp='undef' d_bcopy='undef' @@ -346,13 +346,13 @@ i_varhdr='varargs.h' i_vfork='undef' incpath='' inews='' -installarchlib='~INST_TOP~\lib\~archname~' +installarchlib='' installbin='~INST_TOP~\bin' installman1dir='~INST_TOP~\man\man1' installman3dir='~INST_TOP~\man\man3' installprivlib='~INST_TOP~\lib' installscript='~INST_TOP~\bin' -installsitearch='~INST_TOP~\lib\site\~archname~' +installsitearch='' installsitelib='~INST_TOP~\lib\site' intsize='4' known_extensions='DB_File Fcntl GDBM_File NDBM_File ODBM_File Opcode POSIX SDBM_File Socket IO attrs Thread' @@ -462,8 +462,8 @@ sig_name='ZERO INT ILL FPE SEGV TERM BREAK ABRT' sig_name_init='"ZERO", "INT", "ILL", "FPE", "SEGV", "TERM", "BREAK", "ABRT", 0' sig_num='0, 2, 4, 8, 11, 15, 21, 22, 0' signal_t='void' -sitearch='~INST_TOP~\lib\site\~archname~' -sitearchexp='~INST_TOP~\lib\site\~archname~' +sitearch='' +sitearchexp='' sitelib='~INST_TOP~\lib\site' sitelibexp='~INST_TOP~\lib\site' sizetype='size_t' diff --git a/win32/config.vc b/win32/config.vc index 9797319..d319ac6 100644 --- a/win32/config.vc +++ b/win32/config.vc @@ -21,7 +21,7 @@ afs='false' alignbytes='8' aphostname='' ar='lib' -archlib='~INST_TOP~\lib\~archname~' +archlib='' archlibexp='~INST_TOP~\lib\~archname~' archname='MSWin32' archobjs='' @@ -65,7 +65,7 @@ csh='undef' d_Gconvert='sprintf((b),"%.*g",(n),(x))' d_access='define' d_alarm='undef' -d_archlib='define' +d_archlib='undef' d_attribut='undef' d_bcmp='undef' d_bcopy='undef' @@ -347,13 +347,13 @@ i_vfork='undef' incpath='' inews='' installarchlib='~INST_TOP~\lib\~archname~' -installbin='~INST_TOP~\bin' +installbin='~INST_TOP~\bin\~archname~' installman1dir='~INST_TOP~\man\man1' installman3dir='~INST_TOP~\man\man3' installprivlib='~INST_TOP~\lib' installscript='~INST_TOP~\bin' -installsitearch='~INST_TOP~\lib\site\~archname~' -installsitelib='~INST_TOP~\lib\site' +installsitearch='~INST_TOP~\..\site\~VERSION~\lib\~archname~' +installsitelib='~INST_TOP~\..\site\~VERSION~\lib' intsize='4' known_extensions='DB_File Fcntl GDBM_File NDBM_File ODBM_File Opcode POSIX SDBM_File Socket IO attrs Thread' ksh='' @@ -427,7 +427,7 @@ patchlevel='2' path_sep=';' perl='perl' perladmin='' -perlpath='~INST_TOP~\bin\perl.exe' +perlpath='~INST_TOP~\bin\~archname~\perl.exe' pg='' phostname='hostname' pidtype='int' @@ -462,10 +462,10 @@ sig_name='ZERO INT ILL FPE SEGV TERM BREAK ABRT' sig_name_init='"ZERO", "INT", "ILL", "FPE", "SEGV", "TERM", "BREAK", "ABRT", 0' sig_num='0, 2, 4, 8, 11, 15, 21, 22, 0' signal_t='void' -sitearch='~INST_TOP~\lib\site\~archname~' -sitearchexp='~INST_TOP~\lib\site\~archname~' -sitelib='~INST_TOP~\lib\site' -sitelibexp='~INST_TOP~\lib\site' +sitearch='' +sitearchexp='' +sitelib='~INST_TOP~\..\site\~VERSION~\lib' +sitelibexp='~INST_TOP~\..\site\~VERSION~\lib' sizetype='size_t' sleep='' smail='' diff --git a/win32/config_H.bc b/win32/config_H.bc index a5306b1..c8cfe4a 100644 --- a/win32/config_H.bc +++ b/win32/config_H.bc @@ -1570,8 +1570,8 @@ * This symbol contains the ~name expanded version of ARCHLIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ -#define ARCHLIB "c:\\perl5004.5x\\lib\\MSWin32-x86" /**/ -#define ARCHLIB_EXP (win32_perllib_path(ARCHNAME,NULL)) /**/ +/* #define ARCHLIB "c:\\perl5004.5x\\lib\\MSWin32-x86" /**/ +/* #define ARCHLIB_EXP (win32_perllib_path(ARCHNAME,NULL)) /**/ /* CAT2: * This macro catenates 2 tokens together. @@ -1702,7 +1702,7 @@ * in programs that are not prepared to deal with ~ expansion at run-time. */ #define PRIVLIB "c:\\perl5004.5x\\lib" /**/ -#define PRIVLIB_EXP (win32_perllib_path(NULL)) /**/ +#define PRIVLIB_EXP (win32_get_stdlib(patchlevel)) /**/ /* SIG_NAME: * This symbol contains a list of signal names in order of @@ -1748,8 +1748,8 @@ * This symbol contains the ~name expanded version of SITEARCH, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ -#define SITEARCH "c:\\perl5004.5x\\lib\\site\\MSWin32-x86" /**/ -#define SITEARCH_EXP (win32_perllib_path("site",ARCHNAME,NULL)) /**/ +/* #define SITEARCH "c:\\perl5004.5x\\lib\\site\\MSWin32-x86" /**/ +/* #define SITEARCH_EXP (win32_perllib_path("site",ARCHNAME,NULL)) /**/ /* SITELIB: * This symbol contains the name of the private library for this package. @@ -1765,7 +1765,7 @@ * in programs that are not prepared to deal with ~ expansion at run-time. */ #define SITELIB "c:\\perl5004.5x\\lib\\site" /**/ -#define SITELIB_EXP (win32_perllib_path("site",NULL)) /**/ +#define SITELIB_EXP (win32_get_sitelib(patchlevel)) /**/ /* DLSYM_NEEDS_UNDERSCORE: * This symbol, if defined, indicates that we need to prepend an diff --git a/win32/config_H.gc b/win32/config_H.gc index f053e53..e0f404a 100644 --- a/win32/config_H.gc +++ b/win32/config_H.gc @@ -1570,8 +1570,8 @@ * This symbol contains the ~name expanded version of ARCHLIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ -#define ARCHLIB "c:\\perl5004.5x\\lib\\MSWin32-x86" /**/ -#define ARCHLIB_EXP (win32_perllib_path(ARCHNAME,NULL)) /**/ +/* #define ARCHLIB "c:\\perl5004.5x\\lib\\MSWin32-x86" /**/ +/* #define ARCHLIB_EXP (win32_perllib_path(ARCHNAME,NULL)) /**/ /* CAT2: * This macro catenates 2 tokens together. @@ -1702,7 +1702,7 @@ * in programs that are not prepared to deal with ~ expansion at run-time. */ #define PRIVLIB "c:\\perl5004.5x\\lib" /**/ -#define PRIVLIB_EXP (win32_perllib_path(NULL)) /**/ +#define PRIVLIB_EXP (win32_get_stdlib(patchlevel)) /**/ /* SIG_NAME: * This symbol contains a list of signal names in order of @@ -1748,8 +1748,8 @@ * This symbol contains the ~name expanded version of SITEARCH, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ -#define SITEARCH "c:\\perl5004.5x\\lib\\site\\MSWin32-x86" /**/ -#define SITEARCH_EXP (win32_perllib_path("site",ARCHNAME,NULL)) /**/ +/* #define SITEARCH "c:\\perl5004.5x\\lib\\site\\MSWin32-x86" /**/ +/* #define SITEARCH_EXP (win32_perllib_path("site",ARCHNAME,NULL)) /**/ /* SITELIB: * This symbol contains the name of the private library for this package. @@ -1765,7 +1765,7 @@ * in programs that are not prepared to deal with ~ expansion at run-time. */ #define SITELIB "c:\\perl5004.5x\\lib\\site" /**/ -#define SITELIB_EXP (win32_perllib_path("site",NULL)) /**/ +#define SITELIB_EXP (win32_get_sitelib(patchlevel)) /**/ /* DLSYM_NEEDS_UNDERSCORE: * This symbol, if defined, indicates that we need to prepend an diff --git a/win32/config_H.vc b/win32/config_H.vc index 5795923..c3d2e35 100644 --- a/win32/config_H.vc +++ b/win32/config_H.vc @@ -21,13 +21,6 @@ #ifndef _config_h_ #define _config_h_ -#ifdef PERL_OBJECT -#ifdef PERL_GLOBAL_STRUCT -#error PERL_GLOBAL_STRUCT cannot be defined with PERL_OBJECT -#endif -#define win32_perllib_path PerlEnv_lib_path -#endif - /* LOC_SED: * This symbol holds the complete pathname to the sed program. */ @@ -1577,8 +1570,8 @@ * This symbol contains the ~name expanded version of ARCHLIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ -#define ARCHLIB "c:\\perl5004.5x\\lib\\MSWin32-x86" /**/ -#define ARCHLIB_EXP (win32_perllib_path(ARCHNAME,NULL)) /**/ +/* #define ARCHLIB "c:\\perl5004.5x\\lib\\MSWin32-x86" /**/ +/* #define ARCHLIB_EXP (win32_perllib_path(ARCHNAME,NULL)) /**/ /* CAT2: * This macro catenates 2 tokens together. @@ -1709,7 +1702,7 @@ * in programs that are not prepared to deal with ~ expansion at run-time. */ #define PRIVLIB "c:\\perl5004.5x\\lib" /**/ -#define PRIVLIB_EXP (win32_perllib_path(NULL)) /**/ +#define PRIVLIB_EXP (win32_get_stdlib(patchlevel)) /**/ /* SIG_NAME: * This symbol contains a list of signal names in order of @@ -1755,8 +1748,8 @@ * This symbol contains the ~name expanded version of SITEARCH, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ -#define SITEARCH "c:\\perl5004.5x\\lib\\site\\MSWin32-x86" /**/ -#define SITEARCH_EXP (win32_perllib_path("site",ARCHNAME,NULL)) /**/ +/* #define SITEARCH "c:\\perl5004.5x\\lib\\site\\MSWin32-x86" /**/ +/* #define SITEARCH_EXP (win32_perllib_path("site",ARCHNAME,NULL)) /**/ /* SITELIB: * This symbol contains the name of the private library for this package. @@ -1772,7 +1765,7 @@ * in programs that are not prepared to deal with ~ expansion at run-time. */ #define SITELIB "c:\\perl5004.5x\\lib\\site" /**/ -#define SITELIB_EXP (win32_perllib_path("site",NULL)) /**/ +#define SITELIB_EXP (win32_get_sitelib(patchlevel)) /**/ /* DLSYM_NEEDS_UNDERSCORE: * This symbol, if defined, indicates that we need to prepend an diff --git a/win32/config_h.PL b/win32/config_h.PL index 3e54688..0a4e6ce 100644 --- a/win32/config_h.PL +++ b/win32/config_h.PL @@ -37,21 +37,21 @@ while () munge(); s/\\\$/\$/g; s#/[ *\*]*\*/#/**/#; - if (/^\s*#define\s+ARCHLIB_EXP/) - { - $_ = "#define ARCHLIB_EXP (win32_perllib_path(ARCHNAME,NULL))\t/**/\n"; - } + # if (/^\s*#define\s+ARCHLIB_EXP/) + # { + # $_ = "#define ARCHLIB_EXP (win32_perllib_path(ARCHNAME,NULL))\t/**/\n"; + # } if (/^\s*#define\s+PRIVLIB_EXP/) { - $_ = "#define PRIVLIB_EXP (win32_perllib_path(NULL))\t/**/\n" - } - if (/^\s*#define\s+SITEARCH_EXP/) - { - $_ = "#define SITEARCH_EXP (win32_perllib_path(\"site\",ARCHNAME,NULL))\t/**/\n"; + $_ = "#define PRIVLIB_EXP (win32_get_stdlib(patchlevel))\t/**/\n" } + # if (/^\s*#define\s+SITEARCH_EXP/) + # { + # $_ = "#define SITEARCH_EXP (win32_perllib_path(\"site\",ARCHNAME,NULL))\t/**/\n"; + # } if (/^\s*#define\s+SITELIB_EXP/) { - $_ = "#define SITELIB_EXP (win32_perllib_path(\"site\",NULL))\t/**/\n"; + $_ = "#define SITELIB_EXP (win32_get_sitelib(patchlevel))\t/**/\n"; } print H; } diff --git a/win32/config_sh.PL b/win32/config_sh.PL index 0c3713c..8194988 100644 --- a/win32/config_sh.PL +++ b/win32/config_sh.PL @@ -10,6 +10,7 @@ if ($] =~ /\.(\d\d\d)?(\d\d)?$/) { # should always be true $opt{SUBVERSION} = $2 || '00'; } +$opt{VERSION} = $]; $opt{'cf_by'} = $ENV{USERNAME} unless $opt{'cf_by'}; $opt{'cf_email'} = $opt{'cf_by'} . '@' . (gethostbyname('localhost'))[0] unless $opt{'cf_email'}; diff --git a/win32/runperl.c b/win32/runperl.c index cbda241..755b386 100644 --- a/win32/runperl.c +++ b/win32/runperl.c @@ -79,7 +79,8 @@ public: }; -extern char * g_win32_perllib_path(char *sfx,...); +extern char * g_win32_get_stdlib(char *pl); +extern char * g_win32_get_sitelib(char *pl); class CPerlEnv : public IPerlEnv { public: @@ -92,17 +93,13 @@ public: { return putenv(envstring); }; - virtual char* LibPath(char *sfx, ...) - { - LPSTR ptr1, ptr2, ptr3, ptr4, ptr5; - va_list ap; - va_start(ap,sfx); - ptr1 = va_arg(ap,char *); - ptr2 = va_arg(ap,char *); - ptr3 = va_arg(ap,char *); - ptr4 = va_arg(ap,char *); - ptr5 = va_arg(ap,char *); - return g_win32_perllib_path(sfx, ptr1, ptr2, ptr3, ptr4, ptr5); + virtual char* LibPath(char *pl) + { + return g_win32_get_stdlib(pl); + }; + virtual char* SiteLibPath(char *pl) + { + return g_win32_get_sitelib(pl); }; }; diff --git a/win32/win32.c b/win32/win32.c index d5caff3..7733c05 100644 --- a/win32/win32.c +++ b/win32/win32.c @@ -65,8 +65,10 @@ int _CRT_glob = 0; #define EXECF_SPAWN_NOWAIT 3 #if defined(PERL_OBJECT) -#undef win32_perllib_path -#define win32_perllib_path g_win32_perllib_path +#undef win32_get_stdlib +#define win32_get_stdlib g_win32_get_stdlib +#undef win32_get_sitelib +#define win32_get_sitelib g_win32_get_sitelib #undef do_aspawn #define do_aspawn g_do_aspawn #undef do_spawn @@ -153,29 +155,213 @@ IsWinNT(void) { return (os_id() == VER_PLATFORM_WIN32_NT); } +char* +GetRegStrFromKey(HKEY hkey, const char *lpszValueName, char** ptr, DWORD* lpDataLen) +{ /* Retrieve a REG_SZ or REG_EXPAND_SZ from the registry */ + HKEY handle; + DWORD type; + const char *subkey = "Software\\Perl"; + long retval; + + retval = RegOpenKeyEx(hkey, subkey, 0, KEY_READ, &handle); + if(retval == ERROR_SUCCESS){ + retval = RegQueryValueEx(handle, lpszValueName, 0, &type, NULL, lpDataLen); + if(retval == ERROR_SUCCESS && type == REG_SZ) { + if(*ptr != NULL) { + Renew(*ptr, *lpDataLen, char); + } + else { + New(1312, *ptr, *lpDataLen, char); + } + retval = RegQueryValueEx(handle, lpszValueName, 0, NULL, (PBYTE)*ptr, lpDataLen); + if(retval != ERROR_SUCCESS) { + Safefree(ptr); + ptr = NULL; + } + } + RegCloseKey(handle); + } + return *ptr; +} + +char* +GetRegStr(const char *lpszValueName, char** ptr, DWORD* lpDataLen) +{ + *ptr = GetRegStrFromKey(HKEY_CURRENT_USER, lpszValueName, ptr, lpDataLen); + if(*ptr == NULL) + { + *ptr = GetRegStrFromKey(HKEY_LOCAL_MACHINE, lpszValueName, ptr, lpDataLen); + } + return *ptr; +} + char * -win32_perllib_path(char *sfx,...) +win32_get_stdlib(char *pl) { - va_list ap; - char *end; - va_start(ap,sfx); - GetModuleFileName((w32_perldll_handle == INVALID_HANDLE_VALUE) - ? GetModuleHandle(NULL) - : 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); + static char szStdLib[] = "lib"; + int len = 0, newSize; + char szBuffer[MAX_PATH+1]; + char szModuleName[MAX_PATH]; + int result; + DWORD dwDataLen; + char *lpPath = NULL; + char *ptr; + + /* $stdlib = $HKCU{"lib-$]"} || $HKLM{"lib-$]"} || $HKCU{"lib"} || $HKLM{"lib"} || ""; */ + sprintf(szBuffer, "%s-%s", szStdLib, pl); + lpPath = GetRegStr(szBuffer, &lpPath, &dwDataLen); + if(lpPath == NULL) + lpPath = GetRegStr(szStdLib, &lpPath, &dwDataLen); + + /* $stdlib .= ";$EMD/../../lib" */ + GetModuleFileName(GetModuleHandle(NULL), szModuleName, sizeof(szModuleName)); + ptr = strrchr(szModuleName, '\\'); + if(ptr != NULL) + { + *ptr = '\0'; + ptr = strrchr(szModuleName, '\\'); + if(ptr != NULL) + { + *ptr = '\0'; + ptr = strrchr(szModuleName, '\\'); + } + } + if(ptr == NULL) + { + ptr = szModuleName; + *ptr = '\\'; + } + strcpy(++ptr, szStdLib); + + /* check that this path exists */ + GetCurrentDirectory(sizeof(szBuffer), szBuffer); + result = SetCurrentDirectory(szModuleName); + SetCurrentDirectory(szBuffer); + if(result == 0) + { + GetModuleFileName(GetModuleHandle(NULL), szModuleName, sizeof(szModuleName)); + ptr = strrchr(szModuleName, '\\'); + if(ptr != NULL) + strcpy(++ptr, szStdLib); + } + + newSize = strlen(szModuleName) + 1; + if(lpPath != NULL) + { + len = strlen(lpPath); + newSize += len + 1; /* plus 1 for ';' */ + lpPath = Renew(lpPath, newSize, char); + } + else + New(1310, lpPath, newSize, char); + + if(lpPath != NULL) + { + if(len != 0) + lpPath[len++] = ';'; + strcpy(&lpPath[len], szModuleName); + } + return lpPath; +} + +char * +get_sitelib_part(char* lpRegStr, char* lpPathStr) +{ + char szBuffer[MAX_PATH+1]; + char szModuleName[MAX_PATH]; + DWORD dwDataLen; + int len = 0; + int result; + char *lpPath = NULL; + char *ptr; + + lpPath = GetRegStr(lpRegStr, &lpPath, &dwDataLen); + + /* $sitelib .= ";$EMD/../../../" */ + GetModuleFileName(GetModuleHandle(NULL), szModuleName, sizeof(szModuleName)); + ptr = strrchr(szModuleName, '\\'); + if(ptr != NULL) + { + *ptr = '\0'; + ptr = strrchr(szModuleName, '\\'); + if(ptr != NULL) + { + *ptr = '\0'; + ptr = strrchr(szModuleName, '\\'); + if(ptr != NULL) + { + *ptr = '\0'; + ptr = strrchr(szModuleName, '\\'); + } + } + } + if(ptr == NULL) + { + ptr = szModuleName; + *ptr = '\\'; + } + strcpy(++ptr, lpPathStr); + + /* check that this path exists */ + GetCurrentDirectory(sizeof(szBuffer), szBuffer); + result = SetCurrentDirectory(szModuleName); + SetCurrentDirectory(szBuffer); + + if(result) + { + int newSize = strlen(szModuleName) + 1; + if(lpPath != NULL) + { + len = strlen(lpPath); + newSize += len + 1; /* plus 1 for ';' */ + lpPath = Renew(lpPath, newSize, char); + } + else + New(1311, lpPath, newSize, char); + + if(lpPath != NULL) + { + if(len != 0) + lpPath[len++] = ';'; + strcpy(&lpPath[len], szModuleName); + } + } + return lpPath; +} + +char * +win32_get_sitelib(char *pl) +{ + static char szSiteLib[] = "sitelib"; + char szRegStr[40]; + char szPathStr[MAX_PATH]; + char *lpPath1; + char *lpPath2; + + /* $HKCU{"sitelib-$]"} || $HKLM{"sitelib-$]"} . ---; */ + sprintf(szRegStr, "%s-%s", szSiteLib, pl); + sprintf(szPathStr, "site\\%s\\lib", pl); + lpPath1 = get_sitelib_part(szRegStr, szPathStr); + + /* $HKCU{'sitelib'} || $HKLM{'sitelib'} . ---; */ + lpPath2 = get_sitelib_part(szSiteLib, "site\\lib"); + if(lpPath1 == NULL) + return lpPath2; + + if(lpPath2 == NULL) + return lpPath1; + + int len = strlen(lpPath1); + int newSize = len + strlen(lpPath2) + 2; /* plus one for ';' */ + + lpPath1 = Renew(lpPath1, newSize, char); + if(lpPath1 != NULL) + { + lpPath1[len++] = ';'; + strcpy(&lpPath1[len], lpPath2); + } + Safefree(lpPath2); + return lpPath1; } @@ -817,51 +1003,6 @@ win32_stat(const char *path, struct stat *buffer) #ifndef USE_WIN32_RTL_ENV -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; -} - DllExport char * win32_getenv(const char *name) { @@ -879,9 +1020,8 @@ win32_getenv(const char *name) } if(curitem == NULL) { - unsigned long dwDataLen = curlen; if(strcmp("PERL5DB", name) == 0) - curitem = GetRegStr(name, "", curitem, &dwDataLen); + curitem = GetRegStr(name, &curitem, &curlen); } return curitem; } diff --git a/win32/win32.h b/win32/win32.h index bb2190b..841dbc5 100644 --- a/win32/win32.h +++ b/win32/win32.h @@ -16,7 +16,8 @@ #ifdef PERL_GLOBAL_STRUCT #error PERL_GLOBAL_STRUCT cannot be defined with PERL_OBJECT #endif -#define win32_perllib_path PerlEnv_lib_path +#define win32_get_stdlib PerlEnv_lib_path +#define win32_get_sitelib PerlEnv_sitelib_path #endif #ifdef __GNUC__ @@ -205,7 +206,8 @@ extern int do_aspawn(void *really, void **mark, void **sp); extern int do_spawn(char *cmd); extern int do_spawn_nowait(char *cmd); extern char do_exec(char *cmd); -extern char * win32_perllib_path(char *sfx,...); +extern char * win32_get_stdlib(char *pl); +extern char * win32_get_sitelib(char *pl); extern int IsWin95(void); extern int IsWinNT(void);