diff --git a/builtin.c b/builtin.c index 34865ec9a4bb..12c3cd067436 100644 --- a/builtin.c +++ b/builtin.c @@ -29,6 +29,12 @@ struct BuiltinFuncDescriptor { bool is_experimental; }; +#ifdef WIN32 + XS_EXTERNAL(w32_GetCwd); +#elif defined(HAS_GETCWD) + XS_EXTERNAL(XS_Internals_getcwd); +#endif + #define warn_experimental_builtin(name) S_warn_experimental_builtin(aTHX_ name) static void S_warn_experimental_builtin(pTHX_ const char *name) { @@ -640,6 +646,11 @@ static const struct BuiltinFuncDescriptor builtins[] = { /* list functions */ { "indexed", SHORTVER(5,39), &XS_builtin_indexed, &ck_builtin_funcN, 0, false }, { "export_lexically", NO_BUNDLE, &XS_builtin_export_lexically, NULL, 0, true }, +#ifdef WIN32 + { "getcwd", NO_BUNDLE, &w32_GetCwd, NULL, 0, true }, +#elif defined(HAS_GETCWD) + { "getcwd", NO_BUNDLE, &XS_Internals_getcwd, NULL, 0, true }, +#endif { NULL, 0, NULL, NULL, 0, false } }; diff --git a/cpan/Win32/Win32.pm b/cpan/Win32/Win32.pm index d73628199fe9..9fcdf1bdd0e8 100644 --- a/cpan/Win32/Win32.pm +++ b/cpan/Win32/Win32.pm @@ -8,7 +8,7 @@ package Win32; require DynaLoader; @ISA = qw|Exporter DynaLoader|; - $VERSION = '0.59_01'; + $VERSION = '0.59_04'; $XS_VERSION = $VERSION; $VERSION = eval $VERSION; diff --git a/cpan/Win32/Win32.xs b/cpan/Win32/Win32.xs index 980e8414c395..3e3ce727851b 100644 --- a/cpan/Win32/Win32.xs +++ b/cpan/Win32/Win32.xs @@ -936,31 +936,72 @@ XS(w32_SetChildShowWindow) XS(w32_GetCwd) { dXSARGS; - char* ptr; + /* Make the host for current directory */ + char buf [MAX_PATH+1]; + char* dir; + DWORD dirlen; + DWORD dirretlen; + PH_GCDB_T dirinfo; + unsigned int gotutf8; + SV * sv; if (items) - Perl_croak(aTHX_ "usage: Win32::GetCwd()"); + croak_xs_usage(cv, ""); + EXTEND(SP,1); - /* Make the host for current directory */ - ptr = PerlEnv_get_childdir(); - /* - * If ptr != Nullch - * then it worked, set PV valid, - * else return 'undef' - */ - if (ptr) { - SV *sv = sv_newmortal(); - sv_setpv(sv, ptr); - PerlEnv_free_childdir(ptr); + dXSTARG; + sv = TARG; + if(SvTYPE(sv) >= SVt_PV) { + SV_CHECK_THINKFIRST_COW_DROP(sv); + if(SvLEN(sv) >= 32) { + dirlen = (DWORD)SvLEN(sv); + dir = SvPVX(sv); + } + else + goto stk_buf; + } + else { + stk_buf: + dirlen = sizeof(buf); + dir = buf; + } + + dirinfo.want_wide = 0; + dirinfo.want_utf8_maybe = XSANY.any_i32 == 'W' ? 1 : 0; + + retry_dir: + dirinfo.len_tchar = dirlen; + dirretlen = PerlEnv_get_childdir_tbuf(dir, dirinfo); + gotutf8 = dirretlen & 0x80000000; + dirretlen &= ~0x80000000; + if(dirretlen >= dirlen) { + dirlen = dirretlen + 1; + dir = alloca(dirlen); + goto retry_dir; + } + else if(!dirretlen){ + //translate_to_errno(); //TODO XXXX + sv = &PL_sv_undef; + } + else if(SvTYPE(sv) >= SVt_PV && dir == SvPVX(sv)) { + SvCUR_set(sv, dirretlen); + SvNIOK_off(sv); + SvPOK_on(sv); + if(gotutf8) + SvUTF8_on(sv); + SvSETMAGIC(sv); + } + else { + if(gotutf8) + SvUTF8_on(sv); + sv_setpvn_mg(sv, dir, dirretlen); + } #ifndef INCOMPLETE_TAINTS SvTAINTED_on(sv); #endif - EXTEND(SP,1); - ST(0) = sv; - XSRETURN(1); - } - XSRETURN_UNDEF; + PUSHs(sv); + PUTBACK; } XS(w32_SetCwd) @@ -2023,6 +2064,8 @@ PROTOTYPES: DISABLE BOOT: { const char *file = __FILE__; + GV * gv; + CV * cv; if (g_osver.dwOSVersionInfoSize == 0) { g_osver.dwOSVersionInfoSize = sizeof(g_osver); @@ -2051,8 +2094,19 @@ BOOT: newXS("Win32::GetFolderPath", w32_GetFolderPath, file); newXS("Win32::IsAdminUser", w32_IsAdminUser, file); newXS("Win32::GetFileVersion", w32_GetFileVersion, file); - - newXS("Win32::GetCwd", w32_GetCwd, file); + gv = gv_fetchpvn("Win32::GetCwd", sizeof("Win32::GetCwd")-1, 0, SVt_PVGV); + cv = GvCV(gv); + if(cv) { + GvCV_set(gv, NULL); + SvREFCNT_dec_NN(cv); + } + cv = newXS("Win32::GetCwdA", w32_GetCwd, file); + XSANY.any_i32 = 'A'; + SvREFCNT_inc(cv); + GvCV_set(gv,cv); + + cv = newXS("Win32::GetCwdW", w32_GetCwd, file); + XSANY.any_i32 = 'W'; newXS("Win32::SetCwd", w32_SetCwd, file); newXS("Win32::GetNextAvailDrive", w32_GetNextAvailDrive, file); newXS("Win32::GetLastError", w32_GetLastError, file); diff --git a/iperlsys.h b/iperlsys.h index 40ff8a310399..92c79616d97f 100644 --- a/iperlsys.h +++ b/iperlsys.h @@ -470,6 +470,7 @@ typedef void* (*LPEnvGetChildenv)(struct IPerlEnv*); typedef void (*LPEnvFreeChildenv)(struct IPerlEnv*, void* env); typedef char* (*LPEnvGetChilddir)(struct IPerlEnv*); typedef void (*LPEnvFreeChilddir)(struct IPerlEnv*, char* dir); +typedef unsigned int (*LPEnvGetChilddir_tbuf)(struct IPerlEnv*, char* ptr, PH_GCDB_T info); # ifdef HAS_ENVGETENV typedef char* (*LPENVGetenv)(struct IPerlEnv*, const char *varname); typedef char* (*LPENVGetenv_len)(struct IPerlEnv*, @@ -497,6 +498,7 @@ struct IPerlEnv LPEnvFreeChildenv pFreeChildenv; LPEnvGetChilddir pGetChilddir; LPEnvFreeChilddir pFreeChilddir; + LPEnvGetChilddir_tbuf pGetChilddir_tbuf; # ifdef HAS_ENVGETENV LPENVGetenv pENVGetenv; LPENVGetenv_len pENVGetenv_len; @@ -532,6 +534,8 @@ struct IPerlEnvInfo (*PL_Env->pGetChilddir)(PL_Env) # define PerlEnv_free_childdir(d) \ (*PL_Env->pFreeChilddir)(PL_Env, (d)) +# define PerlEnv_get_childdir_tbuf(_p,_i) \ + (*PL_Env->pGetChilddir_tbuf)(PL_Env,(_p),(_i)) # ifdef HAS_ENVGETENV # define PerlEnv_ENVgetenv(str) \ (*PL_Env->pENVGetenv)(PL_Env,(str)) @@ -583,6 +587,7 @@ struct IPerlEnvInfo # define PerlEnv_get_childenv() win32_get_childenv() # define PerlEnv_free_childenv(e) win32_free_childenv((e)) # define PerlEnv_get_childdir() win32_get_childdir() +# define PerlEnv_get_childdir_tbuf(_p,_i) win32_get_childdir_tbuf((_p),(_i)) # define PerlEnv_free_childdir(d) win32_free_childdir((d)) # else # define PerlEnv_clearenv(str) (ENV_LOCK, (clearenv(str) \ diff --git a/lib/Internals.pod b/lib/Internals.pod index af59ed7b07c3..be679cec873a 100644 --- a/lib/Internals.pod +++ b/lib/Internals.pod @@ -57,22 +57,6 @@ to implement higher-level behavior which should be used instead. See the core implementation for the exact meaning of the readonly flag for each internal variable type. -=item Internals::getcwd() - -Internally core maintained version of L or -L. Only for use if loading L or -calling C and its C to L will -somehow break a TAP test in a C<.t>. - -Not defined on all platforms and all perl build flag configs. May not set -C env var. May disappear at any time. Probe for the sub's existance -before calling it and write C/C if C is -unavailable. Although this would be a bug, there is no guarentee it will -return the same identical string as L or -L. The public implementations can get patched -in the future for some future discovered bug while this sub keeps the buggy -return value. - =item hv_clear_placeholders(%hash) Clear any placeholders from a locked hash. Should not be used directly. diff --git a/lib/blib.pm b/lib/blib.pm index 48c1fb00ab07..fa1a9ce32dbc 100644 --- a/lib/blib.pm +++ b/lib/blib.pm @@ -52,8 +52,8 @@ sub import # That means that it would not be possible to run `make test` # for the Win32 module because blib.pm would always load the # installed version before @INC gets updated with the blib path. - if(defined &Internals::getcwd) { - $dir = Internals::getcwd(); + if(defined &builtin::getcwd) { + $dir = builtin::getcwd(); } else { chomp($dir = `cd`); } diff --git a/lib/builtin.pm b/lib/builtin.pm index 0980884359b7..6ccd50c1ad4e 100644 --- a/lib/builtin.pm +++ b/lib/builtin.pm @@ -1,4 +1,4 @@ -package builtin 0.015; +package builtin 0.016; use v5.40; @@ -174,6 +174,29 @@ Returns the floating-point "Not-a-Number" value. Available starting with Perl 5.40. +=head2 getcwd + + $cwd = builtin::getcwd(); + +Core maintained version of L or +L. It is suggested that you only use +this sub if loading L or calling C and its +C to L will somehow break a TAP test in a C<.t> or +for some esoteric reason L<@INC|perlvar/@INC> L<%INC|perlvar/%INC> or +L<$INC|perlvar/$INC> are unusable or temporarily broken or undef, or you are +running perl.bin without perl's L or +L. + +C may not always return the same string as +L or L. +This sub may have less Perl specific OS portability fixes vs the 2 +subs above, and could return C in situations where those 2 would return +a successful string value. C is not guarenteed to set +C env var. Although this would be a bug, there is no guarentee it will +return the same identical string. Note the public implementations of the other +2 subs can get patched in the future for some future discovered bug while this +sub keeps the buggy return value string. + =head2 weaken weaken($ref); diff --git a/lib/builtin.t b/lib/builtin.t index ce5de3455b60..2c8400b988ff 100644 --- a/lib/builtin.t +++ b/lib/builtin.t @@ -440,6 +440,19 @@ TODO: { is($HASH{key}, "val", 'Lexically exported hash is accessible'); } +# Test getcwd +{ + require Cwd; + + eval "getcwd()"; + ok($@, "no main::getcwd"); + + TODO: { + local $::TODO = "backslash vs forward slash problems on Win32"; + is(builtin::getcwd(), Cwd::getcwd(), "builtin::getcwd() eq Cwd::getcwd()"); + } +} + # load_module { use builtin qw( load_module ); diff --git a/makedef.pl b/makedef.pl index 6989cc6286d5..82dba529d441 100644 --- a/makedef.pl +++ b/makedef.pl @@ -347,6 +347,7 @@ sub readvar { ++$skip{$_} foreach qw( Perl_my_popen Perl_my_pclose + win32_get_childdir_tbuf ); ++$export{$_} foreach qw(perl_get_host_info perl_alloc_override); ++$export{perl_clone_host} if $define{USE_ITHREADS}; @@ -844,6 +845,7 @@ sub readvar { win32_free_childenv win32_get_childdir win32_get_childenv + win32_get_childdir_tbuf win32_spawnvp Perl_init_os_extras Perl_win32_init diff --git a/pod/perldelta.pod b/pod/perldelta.pod index 912907de13c1..a878c5cf31be 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -131,6 +131,12 @@ shelling out to a new C, this was fixed and the C when using C and L is obtained with a fast same-process API function call the way C and C do it. +=item builtin.pm + +C was updated from 0.015 to 0.016. + +C was added as experimental. + =back =head2 Removed Modules and Pragmata @@ -348,12 +354,9 @@ well. =over 4 -=item Internals::getcwd() is documented as very limited platform availability +=item * -C is documented as experimental, unsupported, not-bug-free -and removeable in the future, and very limited availability on random -platforms and perl core build flags. Basically C only, and only for -esoteric C<.t> TAP situations and esoteric internal core reasons. +XXX =back diff --git a/universal.c b/universal.c index 2f0374617d1c..23f722a108e1 100644 --- a/universal.c +++ b/universal.c @@ -1131,9 +1131,9 @@ XS(XS_re_regexp_pattern) NOT_REACHED; /* NOTREACHED */ } -#if defined(HAS_GETCWD) && defined(PERL_IS_MINIPERL) +#if defined(HAS_GETCWD) -XS(XS_Internals_getcwd) +XS_EXTERNAL(XS_Internals_getcwd) { dXSARGS; if (items != 0) @@ -1353,7 +1353,7 @@ static const struct xsub_details these_details[] = { /* Always offer backup, Win32CORE.c vs AUTOLOAD vs Win32.pm vs Win32.dll vs loading a .pm or .dll at all, has rare dep/recursion problems in certain modules or .t files. See w32_GetCwd() . */ - {"Internals::getcwd", w32_GetCwd, "", 0 }, + /*{"Internals::getcwd", w32_GetCwd, "", 0 },*/ #endif {"Tie::Hash::NamedCapture::_tie_it", XS_NamedCapture_tie_it, NULL, 0 }, {"Tie::Hash::NamedCapture::TIEHASH", XS_NamedCapture_TIEHASH, NULL, 0 }, diff --git a/win32/perlhost.h b/win32/perlhost.h index 8f76299cb997..a865bbb8c84d 100644 --- a/win32/perlhost.h +++ b/win32/perlhost.h @@ -141,6 +141,7 @@ class CPerlHost void FreeChildEnv(void* pStr) { FreeLocalEnvironmentStrings((char*)pStr); }; char* GetChildDir(void); void FreeChildDir(char* pStr); + unsigned int GetChildDirTBuf(char* buf, PH_GCDB_T info); void Reset(void); void Clearenv(void); @@ -505,6 +506,12 @@ PerlEnvFreeChilddir(struct IPerlEnv* piPerl, char* childDir) IPERL2HOST(piPerl)->FreeChildDir(childDir); } +unsigned int +PerlEnvGetChilddirTBuf(struct IPerlEnv* piPerl, char* buf, PH_GCDB_T info) +{ + return IPERL2HOST(piPerl)->GetChildDirTBuf(buf,info); +} + unsigned long PerlEnvOsId(struct IPerlEnv* piPerl) { @@ -552,6 +559,7 @@ const struct IPerlEnv perlEnv = PerlEnvFreeChildenv, PerlEnvGetChilddir, PerlEnvFreeChilddir, + PerlEnvGetChilddirTBuf, PerlEnvOsId, PerlEnvLibPath, PerlEnvSiteLibPath, @@ -2408,6 +2416,85 @@ CPerlHost::GetChildDir(void) return ptr; } +unsigned int +CPerlHost::GetChildDirTBuf(char* ptr, PH_GCDB_T info) +{ + BOOL use_default; + int retlen; + DWORD length; + DWORD wlength; + WCHAR * wptr; + DWORD len_tchar = info.len_tchar; + if(len_tchar < 2) + croak_no_mem_ext(STR_WITH_LEN("CPerlHost::GetChildDirTBuf")); + if(info.want_wide || info.want_utf8_maybe) { + if(info.want_utf8_maybe) { + wlength = len_tchar <= 0xFFFF ? len_tchar : 0xFFFF; + wptr = (WCHAR *)alloca(wlength * sizeof(WCHAR)); + } + else { + wlength = len_tchar; + wptr = (WCHAR *)ptr; + } + length = m_pvDir->GetCurrentDirectoryW(wlength, wptr); + if(!length) + goto syscall_fail; + else if(length >= wlength) { +/* anti 2 buffers here, utf8 or WIDE doesn't matter because min 2 bytes check */ + wptr = (WCHAR *)ptr; + wptr[wlength-1] = '\0'; + return length; + } + if (length > 3) { + if ((wptr[length-1] == '\\') || (wptr[length-1] == '/')) { + wptr[length-1] = 0; + length--; + } + } + if(info.want_utf8_maybe) { + use_default = FALSE; + retlen = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, + wptr, length+1, ptr, len_tchar, + NULL, &use_default); + if (use_default && retlen) { + retlen = WideCharToMultiByte(CP_UTF8, 0, + wptr, length+1, ptr, len_tchar, + NULL, NULL); + if(!retlen) + goto syscall_fail; + length = (unsigned int)retlen-1; + length |= 0x80000000; + } + else { + length = (unsigned int)retlen-1; + } + if(!retlen) { /*syscall failed unknown why */ + syscall_fail: + wptr = (WCHAR *)ptr; + /* utf8 or WIDE doesn't matter because min 2 bytes check */ + wptr[0] = '\0'; + return 0; + } + } + } + else { + length = m_pvDir->GetCurrentDirectoryA(len_tchar, ptr); + if(!length) + goto syscall_fail; + else if(length >= len_tchar) { + ptr[len_tchar-1] = '\0'; + return length; + } + if (length > 3) { + if ((ptr[length-1] == '\\') || (ptr[length-1] == '/')) { + ptr[length-1] = 0; + length--; + } + } + } + return length; +} + void CPerlHost::FreeChildDir(char* pStr) { diff --git a/win32/perllib.c b/win32/perllib.c index 64d9fdb8487f..f1285ea86416 100644 --- a/win32/perllib.c +++ b/win32/perllib.c @@ -52,6 +52,8 @@ win32_checkTLS(PerlInterpreter *host_perl) dTHX; if (host_perl != my_perl) { int *nowhere = NULL; + *nowhere = 0; /* this segfault is deliberate, + so you can see the stack trace */ abort(); } } @@ -232,7 +234,8 @@ BOOL APIENTRY DllMain(HINSTANCE hModule, /* DLL module handle */ DWORD fdwReason, /* reason called */ LPVOID lpvReserved) /* reserved */ -{ +{ + PERL_UNUSED_ARG(lpvReserved); switch (fdwReason) { /* The DLL is attaching to a process due to process * initialization or a call to LoadLibrary. diff --git a/win32/vdir.h b/win32/vdir.h index f06830af41ac..01ead5769a23 100644 --- a/win32/vdir.h +++ b/win32/vdir.h @@ -32,27 +32,25 @@ class VDir int SetCurrentDirectoryW(WCHAR *lpBuffer); inline int GetDefault(void) { return nDefault; }; - inline char* GetCurrentDirectoryA(int dwBufSize, char *lpBuffer) + inline unsigned int GetCurrentDirectoryA(int dwBufSize, char *lpBuffer) { char* ptr = dirTableA[nDefault]; - while (--dwBufSize) - { - if ((*lpBuffer++ = *ptr++) == '\0') - break; - } - *lpBuffer = '\0'; - return /* unused */ NULL; + unsigned int len = (unsigned int)strlen(ptr); + unsigned int cpylen = len <= ((unsigned int)dwBufSize)-1 + ? len : ((unsigned int)dwBufSize)-1; + lpBuffer = (char*)memcpy((void*)lpBuffer, (void*)ptr, cpylen); + lpBuffer[cpylen] = '\0'; + return len; }; - inline WCHAR* GetCurrentDirectoryW(int dwBufSize, WCHAR *lpBuffer) + inline unsigned int GetCurrentDirectoryW(int dwBufSize, WCHAR *lpBuffer) { WCHAR* ptr = dirTableW[nDefault]; - while (--dwBufSize) - { - if ((*lpBuffer++ = *ptr++) == '\0') - break; - } - *lpBuffer = '\0'; - return /* unused */ NULL; + unsigned int len = (unsigned int)wcslen(ptr); + unsigned int cpylen = len <= ((unsigned int)dwBufSize)-1 + ? len : ((unsigned int)dwBufSize)-1; + lpBuffer = (WCHAR*)memcpy((void*)lpBuffer, (void*)ptr, cpylen*sizeof(WCHAR)); + lpBuffer[cpylen] = '\0'; + return len; }; DWORD CalculateEnvironmentSpace(void); diff --git a/win32/win32.c b/win32/win32.c index 08528b5533be..9a9fd654abca 100644 --- a/win32/win32.c +++ b/win32/win32.c @@ -4488,11 +4488,22 @@ DllExport char* win32_get_childdir(void) { char* ptr; - char szfilename[MAX_PATH+1]; - - GetCurrentDirectoryA(MAX_PATH+1, szfilename); - Newx(ptr, strlen(szfilename)+1, char); - strcpy(ptr, szfilename); + char filenamebuf[MAX_PATH+1]; + char *pfilename = (char *)filenamebuf; + DWORD curlen = sizeof(filenamebuf); + DWORD retlen; + + retry: + retlen = GetCurrentDirectoryA(curlen, pfilename); + if(retlen >= curlen) { + curlen = retlen + 1; + pfilename = alloca(curlen); + goto retry; + } + Newx(ptr, retlen+1, char); + /* if failed sys call (retlen == 0), unknown if buffer ever was written to */ + ptr[retlen] = '\0'; + ptr = MoveD(pfilename, ptr, retlen, char); return ptr; } @@ -4502,6 +4513,88 @@ win32_free_childdir(char* d) Safefree(d); } +#ifndef PERL_IMPLICIT_SYS + +unsigned int +win32_get_childdir_tbuf(char* ptr, PH_GCDB_T info) +{ + BOOL use_default; + int retlen; + DWORD length; + DWORD wlength; + WCHAR * wptr; + DWORD len_tchar = info.len_tchar; + if(len_tchar < 2) + croak_no_mem_ext(STR_WITH_LEN("win32_get_childdir_tbuf")); + if(info.want_wide || info.want_utf8_maybe) { + if(info.want_utf8_maybe) { + wlength = len_tchar <= 0xFFFF ? len_tchar : 0xFFFF; + wptr = (WCHAR *)alloca(wlength * sizeof(WCHAR)); + } + else { + wlength = len_tchar; + wptr = (WCHAR *)ptr; + } + length = GetCurrentDirectoryW(wlength, wptr); + if(!length) + goto syscall_fail; + else if(length >= wlength) { +/* anti 2 buffers here, utf8 or WIDE doesn't matter because min 2 bytes check */ + wptr = (WCHAR *)ptr; + wptr[wlength-1] = '\0'; + return length; + } + if (length > 3) { + if ((wptr[length-1] == '\\') || (wptr[length-1] == '/')) { + wptr[length-1] = 0; + length--; + } + } + if(info.want_utf8_maybe) { + use_default = FALSE; + retlen = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, + wptr, length+1, ptr, len_tchar, + NULL, &use_default); + if (use_default && retlen) { + retlen = WideCharToMultiByte(CP_UTF8, 0, + wptr, length+1, ptr, len_tchar, + NULL, NULL); + if(!retlen) + goto syscall_fail; + length = (unsigned int)retlen; + length |= 0x80000000; + } + else { + length = (unsigned int)retlen; + } + if(!retlen) { /*syscall failed unknown why */ + syscall_fail: + wptr = (WCHAR *)ptr; + /* utf8 or WIDE doesn't matter because min 2 bytes check */ + wptr[0] = '\0'; + return 0; + } + } + } + else { + length = GetCurrentDirectoryA(len_tchar, ptr); + if(!length) + goto syscall_fail; + else if(length >= len_tchar) { + ptr[len_tchar-1] = '\0'; + return length; + } + if (length > 3) { + if ((ptr[length-1] == '\\') || (ptr[length-1] == '/')) { + ptr[length-1] = 0; + length--; + } + } + } + return length; +} + +#endif /* XXX this needs to be made more compatible with the spawnvp() * provided by the various RTLs. In particular, searching for @@ -4530,7 +4623,10 @@ do_spawnvp_handles(int mode, const char *cmdname, const char *const *argv, dTHXa(NULL); int ret; void* env; - char* dir; + char dirbuf [MAX_PATH+1]; + char* dir = dirbuf; + DWORD dirlen = sizeof(dirbuf); + DWORD dirretlen; child_IO_table tbl; STARTUPINFO StartupInfo; PROCESS_INFORMATION ProcessInformation; @@ -4562,7 +4658,24 @@ do_spawnvp_handles(int mode, const char *cmdname, const char *const *argv, aTHXa(PERL_GET_THX); env = PerlEnv_get_childenv(); - dir = PerlEnv_get_childdir(); + + PH_GCDB_T dirinfo; + dirinfo.want_wide = 0; + dirinfo.want_utf8_maybe = 0; + + retry_dir: + dirinfo.len_tchar = dirlen; + dirretlen = PerlEnv_get_childdir_tbuf(dir, dirinfo); + if(dirretlen >= dirlen) { + dirlen = dirretlen + 1; + dir = alloca(dirlen); + goto retry_dir; + } + else if(!dirretlen){ + translate_to_errno(); + ret = -1; + goto RETVAL; + } switch(mode) { case P_NOWAIT: /* asynch + remember result */ @@ -4678,7 +4791,6 @@ do_spawnvp_handles(int mode, const char *cmdname, const char *const *argv, RETVAL: PerlEnv_free_childenv(env); - PerlEnv_free_childdir(dir); Safefree(cmd); if (cname != cmdname) Safefree(cname); @@ -5023,39 +5135,75 @@ XS(w32_SetChildShowWindow) Win32CORE.c AUTOLOAD vs DynaLoader.pm vs Win32.pm, race and recursion and dependency problems can happen in rare cases. For example, see blib.pm Offer Internals::getcwd as a backup at all times. */ -XS_EXTERNAL(w32_GetCwd) +XS(w32_GetCwd) { - - SV *sv; + dXSARGS; /* Make the host for current directory */ - char* ptr = PerlEnv_get_childdir(); - /* - * If ptr != Nullch - * then it worked, set PV valid, - * else return 'undef' - */ - if (ptr) { - dXSTARG; - sv = TARG; - sv_setpv(sv, ptr); - PerlEnv_free_childdir(ptr); + char buf [MAX_PATH+1]; + char* dir; + DWORD dirlen; + DWORD dirretlen; + PH_GCDB_T dirinfo; + SV * sv; + unsigned int gotutf8; + if (items) + croak_xs_usage(cv, ""); + EXTEND(SP,1); + + dXSTARG; + sv = TARG; + + if(SvTYPE(sv) >= SVt_PV) { + SV_CHECK_THINKFIRST_COW_DROP(sv); + if(SvLEN(sv) >= 32) { + dirlen = (DWORD)SvLEN(sv); + dir = SvPVX(sv); + } + else + goto stk_buf; + } + else { + stk_buf: + dirlen = sizeof(buf); + dir = buf; + } -#ifndef INCOMPLETE_TAINTS - SvTAINTED_on(sv); -#endif + dirinfo.want_wide = 0; + dirinfo.want_utf8_maybe = XSANY.any_i32 == 'W' ? 1 : 0; + + retry_dir: + dirinfo.len_tchar = dirlen; + dirretlen = PerlEnv_get_childdir_tbuf(dir, dirinfo); + gotutf8 = dirretlen & 0x80000000; + dirretlen &= ~0x80000000; + if(dirretlen >= dirlen) { + dirlen = dirretlen + 1; + dir = alloca(dirlen); + goto retry_dir; + } + else if(!dirretlen){ + translate_to_errno(); + sv = &PL_sv_undef; + } + else if(SvTYPE(sv) >= SVt_PV && dir == SvPVX(sv)) { + SvCUR_set(sv, dirretlen); + SvNIOK_off(sv); + SvPOK_on(sv); + if(gotutf8) + SvUTF8_on(sv); SvSETMAGIC(sv); } else { - sv = &PL_sv_undef; + if(gotutf8) + SvUTF8_on(sv); + sv_setpvn_mg(sv, dir, dirretlen); } - { - dXSARGS; - PERL_UNUSED_VAR(items); - XSprePUSH; - XPUSHs(sv); - PUTBACK; - } - return; +#ifndef INCOMPLETE_TAINTS + SvTAINTED_on(sv); +#endif + + PUSHs(sv); + PUTBACK; } void diff --git a/win32/win32.h b/win32/win32.h index 193990e9bb27..43558e8093d0 100644 --- a/win32/win32.h +++ b/win32/win32.h @@ -360,6 +360,12 @@ typedef unsigned int uintptr_t; # define _UINTPTR_T_DEFINED #endif +typedef struct { + unsigned int want_wide: 1; + unsigned int want_utf8_maybe: 1; + unsigned int len_tchar: 29; +} PH_GCDB_T; + START_EXTERN_C /* For UNIX compatibility. */ diff --git a/win32/win32iop.h b/win32/win32iop.h index a50d840a2d16..a8052c98d962 100644 --- a/win32/win32iop.h +++ b/win32/win32iop.h @@ -159,6 +159,9 @@ DllExport void win32_free_childenv(void* d); DllExport void win32_clearenv(void); DllExport char * win32_get_childdir(void); DllExport void win32_free_childdir(char* d); +#ifndef PERL_IMPLICIT_SYS +DllExport unsigned int win32_get_childdir_tbuf(char* ptr, PH_GCDB_T info); +#endif DllExport Sighandler_t win32_signal(int sig, Sighandler_t subcode); @@ -343,6 +346,7 @@ END_EXTERN_C #define free_childenv(d) win32_free_childenv(d) #define clearenv() win32_clearenv() #define get_childdir() win32_get_childdir() +#define get_childdir_tbuf(_p,_i) win32_get_childdir_tbuf((_p),(_i)) #define free_childdir(d) win32_free_childdir(d) #undef getenv