/* WIN32.C
*
* (c) 1995 Microsoft Corporation. All rights reserved.
- * Developed by hip communications inc., http://info.hip.com/info/
+ * Developed by hip communications inc.
* Portions (c) 1993 Intergraph Corporation. All rights reserved.
*
* You may distribute under the terms of either the GNU General Public
static BOOL has_shell_metachars(const char *ptr);
static long filetime_to_clock(PFILETIME ft);
static BOOL filetime_from_time(PFILETIME ft, time_t t);
-static char * get_emd_part(SV **leading, char *trailing, ...);
+static char * get_emd_part(SV **leading, STRLEN *const len,
+ char *trailing, ...);
static void remove_dead_process(long deceased);
static long find_pid(int pid);
static char * qualified_path(const char *cmd);
static char * win32_get_xlib(const char *pl, const char *xlib,
- const char *libname);
+ const char *libname, STRLEN *const len);
static LRESULT win32_process_message(HWND hwnd, UINT msg,
WPARAM wParam, LPARAM lParam);
WCHAR fullname[MAX_PATH];
char *ansi;
+ DWORD (__stdcall *pfnGetLongPathNameW)(LPCWSTR, LPWSTR, DWORD) =
+ (DWORD (__stdcall *)(LPCWSTR, LPWSTR, DWORD))
+ GetProcAddress(GetModuleHandle("kernel32.dll"), "GetLongPathNameW");
+
GetModuleFileNameW(module, modulename, sizeof(modulename)/sizeof(WCHAR));
/* Make sure we get an absolute pathname in case the module was loaded
* explicitly by LoadLibrary() with a relative path. */
GetFullPathNameW(modulename, sizeof(fullname)/sizeof(WCHAR), fullname, NULL);
+ /* Make sure we start with the long path name of the module because we
+ * later scan for pathname components to match "5.xx" to locate
+ * compatible sitelib directories, and the short pathname might mangle
+ * this path segment (e.g. by removing the dot on NTFS to something
+ * like "5xx~1.yy") */
+ if (pfnGetLongPathNameW)
+ pfnGetLongPathNameW(fullname, fullname, sizeof(fullname)/sizeof(WCHAR));
+
/* remove \\?\ prefix */
if (memcmp(fullname, L"\\\\?\\", 4*sizeof(WCHAR)) == 0)
memmove(fullname, fullname+4, (wcslen(fullname+4)+1)*sizeof(WCHAR));
/* *prev_pathp (if non-NULL) is expected to be POK (valid allocated SvPVX(sv)) */
static char *
-get_emd_part(SV **prev_pathp, char *trailing_path, ...)
+get_emd_part(SV **prev_pathp, STRLEN *const len, char *trailing_path, ...)
{
char base[10];
va_list ap;
else if (SvPVX(*prev_pathp))
sv_catpvn(*prev_pathp, ";", 1);
sv_catpv(*prev_pathp, mod_name);
+ if(len)
+ *len = SvCUR(*prev_pathp);
return SvPVX(*prev_pathp);
}
}
char *
-win32_get_privlib(const char *pl)
+win32_get_privlib(const char *pl, STRLEN *const len)
{
dTHX;
char *stdlib = "lib";
(void)get_regstr(stdlib, &sv);
/* $stdlib .= ";$EMD/../../lib" */
- return get_emd_part(&sv, stdlib, ARCHNAME, "bin", NULL);
+ return get_emd_part(&sv, len, stdlib, ARCHNAME, "bin", NULL);
}
static char *
-win32_get_xlib(const char *pl, const char *xlib, const char *libname)
+win32_get_xlib(const char *pl, const char *xlib, const char *libname,
+ STRLEN *const len)
{
dTHX;
char regstr[40];
/* $xlib .=
* ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/$]/lib"; */
sprintf(pathstr, "%s/%s/lib", libname, pl);
- (void)get_emd_part(&sv1, pathstr, ARCHNAME, "bin", pl, NULL);
+ (void)get_emd_part(&sv1, NULL, pathstr, ARCHNAME, "bin", pl, NULL);
/* $HKCU{$xlib} || $HKLM{$xlib} . ---; */
(void)get_regstr(xlib, &sv2);
/* $xlib .=
* ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/lib"; */
sprintf(pathstr, "%s/lib", libname);
- (void)get_emd_part(&sv2, pathstr, ARCHNAME, "bin", pl, NULL);
+ (void)get_emd_part(&sv2, NULL, pathstr, ARCHNAME, "bin", pl, NULL);
if (!sv1 && !sv2)
return NULL;
- if (!sv1)
- return SvPVX(sv2);
- if (!sv2)
- return SvPVX(sv1);
-
- sv_catpvn(sv1, ";", 1);
- sv_catsv(sv1, sv2);
+ if (!sv1) {
+ sv1 = sv2;
+ } else if (sv2) {
+ sv_catpvn(sv1, ";", 1);
+ sv_catsv(sv1, sv2);
+ }
+ if (len)
+ *len = SvCUR(sv1);
return SvPVX(sv1);
}
char *
-win32_get_sitelib(const char *pl)
+win32_get_sitelib(const char *pl, STRLEN *const len)
{
- return win32_get_xlib(pl, "sitelib", "site");
+ return win32_get_xlib(pl, "sitelib", "site", len);
}
#ifndef PERL_VENDORLIB_NAME
#endif
char *
-win32_get_vendorlib(const char *pl)
+win32_get_vendorlib(const char *pl, STRLEN *const len)
{
- return win32_get_xlib(pl, "vendorlib", PERL_VENDORLIB_NAME);
+ return win32_get_xlib(pl, "vendorlib", PERL_VENDORLIB_NAME, len);
}
static BOOL
int flag = P_WAIT;
int index = 0;
+ PERL_ARGS_ASSERT_DO_ASPAWN;
+
if (sp <= mark)
return -1;
}
if (flag == P_NOWAIT) {
- if (IsWin95())
- PL_statusvalue = -1; /* >16bits hint for pp_system() */
+ PL_statusvalue = -1; /* >16bits hint for pp_system() */
}
else {
if (status < 0) {
Safefree(argv);
}
if (exectype == EXECF_SPAWN_NOWAIT) {
- if (IsWin95())
- PL_statusvalue = -1; /* >16bits hint for pp_system() */
+ PL_statusvalue = -1; /* >16bits hint for pp_system() */
}
else {
if (status < 0) {
int
Perl_do_spawn(pTHX_ char *cmd)
{
+ PERL_ARGS_ASSERT_DO_SPAWN;
+
return do_spawn2(aTHX_ cmd, EXECF_SPAWN);
}
int
Perl_do_spawn_nowait(pTHX_ char *cmd)
{
+ PERL_ARGS_ASSERT_DO_SPAWN_NOWAIT;
+
return do_spawn2(aTHX_ cmd, EXECF_SPAWN_NOWAIT);
}
bool
Perl_do_exec(pTHX_ const char *cmd)
{
+ PERL_ARGS_ASSERT_DO_EXEC;
+
do_spawn2(aTHX_ cmd, EXECF_EXEC);
return FALSE;
}
errno = ENOTDIR;
return -1;
}
+ if (S_ISDIR(sbuf->st_mode)) {
+ /* Ensure the "write" bit is switched off in the mode for
+ * directories with the read-only attribute set. Borland (at least)
+ * switches it on for directories, which is technically correct
+ * (directories are indeed always writable unless denied by DACLs),
+ * but we want stat() and -w to reflect the state of the read-only
+ * attribute for symmetry with chmod(). */
+ DWORD r = GetFileAttributesA(path);
+ if (r != 0xffffffff && (r & FILE_ATTRIBUTE_READONLY)) {
+ sbuf->st_mode &= ~S_IWRITE;
+ }
+ }
#ifdef __BORLANDC__
- if (S_ISDIR(sbuf->st_mode))
- sbuf->st_mode |= S_IWRITE | S_IEXEC;
+ if (S_ISDIR(sbuf->st_mode)) {
+ sbuf->st_mode |= S_IEXEC;
+ }
else if (S_ISREG(sbuf->st_mode)) {
int perms;
if (l >= 4 && path[l-4] == '.') {
}
static void
-out_of_memory()
+out_of_memory(void)
{
if (PL_curinterp) {
dTHX;
* Has these advantages over putenv() & co.:
* * enables us to store a truly empty value in the
* environment (like in UNIX).
- * * we don't have to deal with RTL globals, bugs and leaks.
+ * * we don't have to deal with RTL globals, bugs and leaks
+ * (specifically, see http://support.microsoft.com/kb/235601).
* * Much faster.
- * Why you may want to enable USE_WIN32_RTL_ENV:
+ * Why you may want to use the RTL environment handling
+ * (previously enabled by USE_WIN32_RTL_ENV):
* * environ[] and RTL functions will not reflect changes,
* which might be an issue if extensions want to access
* the env. via RTL. This cuts both ways, since RTL will
* Perl is calling win32_waitpid() inside a GUI application and the GUI
* is generating messages before the process terminated.
*/
- while (PeekMessage(&msg, NULL, 0, 0, PM_NOREMOVE|PM_NOYIELD))
- /* keep going */ ;
+ PeekMessage(&msg, NULL, 0, 0, PM_NOREMOVE|PM_NOYIELD);
/* Above or other stuff may have set a signal flag */
if (PL_sig_pending)
}
DllExport FILE *
-win32_stdout()
+win32_stdout(void)
{
return (stdout);
}
if (GetFileInformationByHandle((HANDLE)_get_osfhandle(fd), &bhfi)) {
#if defined(WIN64) || defined(USE_LARGE_FILES)
- sbufptr->st_size = (bhfi.nFileSizeHigh << 32) + bhfi.nFileSizeLow ;
+ sbufptr->st_size = ((__int64)bhfi.nFileSizeHigh << 32) | bhfi.nFileSizeLow ;
#endif
sbufptr->st_mode &= 0xFE00;
if (bhfi.dwFileAttributes & FILE_ATTRIBUTE_READONLY)
lock_held = 0;
}
- LOCK_FDPID_MUTEX;
sv_setiv(*av_fetch(w32_fdpid, p[parent], TRUE), childpid);
- UNLOCK_FDPID_MUTEX;
/* set process id so that it can be returned by perl's open() */
PL_forkprocess = childpid;
int childpid, status;
SV *sv;
- LOCK_FDPID_MUTEX;
sv = *av_fetch(w32_fdpid, PerlIO_fileno(pf), TRUE);
if (SvIOK(sv))
childpid = 0;
if (!childpid) {
- UNLOCK_FDPID_MUTEX;
errno = EBADF;
return -1;
}
fclose(pf);
#endif
SvIVX(sv) = 0;
- UNLOCK_FDPID_MUTEX;
if (win32_waitpid(childpid, &status, 0) == -1)
return -1;
}
void
-win32_create_message_window_class()
+win32_create_message_window_class(void)
{
/* create the window class for "message only" windows */
WNDCLASS wc;
}
HWND
-win32_create_message_window()
+win32_create_message_window(void)
{
HWND hwnd = NULL;
void
Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst)
{
+ PERL_ARGS_ASSERT_SYS_INTERN_DUP;
+
dst->perlshell_tokens = NULL;
dst->perlshell_vec = (char**)NULL;
dst->perlshell_items = 0;