X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=win32%2Fwin32.c;h=cef828b9989141247f4be67640f24073bd3c6cb3;hb=6e0733998eff7a098d2d21d5602f3eb2a7521e1f;hp=562dc0bcd8816ad9e7b5591a82a457d885bb2728;hpb=dc0472e9a2aeded945eee8b1bb412d40eff4fe15;p=p5sagit%2Fp5-mst-13.2.git diff --git a/win32/win32.c b/win32/win32.c index 562dc0b..cef828b 100644 --- a/win32/win32.c +++ b/win32/win32.c @@ -19,7 +19,7 @@ # define HWND_MESSAGE ((HWND)-3) #endif #ifndef WC_NO_BEST_FIT_CHARS -# define WC_NO_BEST_FIT_CHARS 0x00000400 +# define WC_NO_BEST_FIT_CHARS 0x00000400 /* requires Windows 2000 or later */ #endif #include #include @@ -60,13 +60,6 @@ typedef struct { #include "EXTERN.h" #include "perl.h" -/* GCC-2.95.2/Mingw32-1.1 forgot the WINAPI on CommandLineToArgvW() */ -#if defined(__MINGW32__) && (__MINGW32_MAJOR_VERSION==1) -# include -#else -EXTERN_C LPWSTR* WINAPI CommandLineToArgvW(LPCWSTR lpCommandLine, int * pNumArgs); -#endif - #define NO_XSLOCKS #define PERL_NO_GET_CONTEXT #include "XSUB.h" @@ -130,12 +123,15 @@ static int do_spawn2(pTHX_ const char *cmd, int exectype); 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); #ifdef USE_ITHREADS static void remove_dead_pseudo_process(long child); @@ -164,7 +160,22 @@ _matherr(struct _exception *a) } #endif -#if _MSC_VER >= 1400 +/* VS2005 (MSC version 14) provides a mechanism to set an invalid + * parameter handler. This functionality is not available in the + * 64-bit compiler from the Platform SDK, which unfortunately also + * believes itself to be MSC version 14. + * + * There is no #define related to _set_invalid_parameter_handler(), + * but we can check for one of the constants defined for + * _set_abort_behavior(), which was introduced into stdlib.h at + * the same time. + */ + +#if _MSC_VER >= 1400 && defined(_WRITE_ABORT_MSG) +# define SET_INVALID_PARAMETER_HANDLER +#endif + +#ifdef SET_INVALID_PARAMETER_HANDLER void my_invalid_parameter_handler(const wchar_t* expression, const wchar_t* function, const wchar_t* file, @@ -191,6 +202,12 @@ IsWinNT(void) return (g_osver.dwPlatformId == VER_PLATFORM_WIN32_NT); } +int +IsWin2000(void) +{ + return (g_osver.dwMajorVersion > 4); +} + EXTERN_C void set_w32_module_name(void) { @@ -204,7 +221,7 @@ set_w32_module_name(void) osver.dwOSVersionInfoSize = sizeof(osver); GetVersionEx(&osver); - if (osver.dwPlatformId == VER_PLATFORM_WIN32_NT) { + if (osver.dwMajorVersion > 4) { WCHAR modulename[MAX_PATH]; WCHAR fullname[MAX_PATH]; char *ansi; @@ -254,7 +271,7 @@ get_regstr_from(HKEY hkey, const char *valuename, SV **svp) HKEY handle; DWORD type; const char *subkey = "Software\\Perl"; - char *str = Nullch; + char *str = NULL; long retval; retval = RegOpenKeyEx(hkey, subkey, 0, KEY_READ, &handle); @@ -292,7 +309,7 @@ get_regstr(const char *valuename, SV **svp) /* *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; @@ -349,19 +366,21 @@ get_emd_part(SV **prev_pathp, char *trailing_path, ...) 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); } - return Nullch; + return NULL; } char * -win32_get_privlib(const char *pl) +win32_get_privlib(const char *pl, STRLEN *const len) { dTHX; char *stdlib = "lib"; char buffer[MAX_PATH+1]; - SV *sv = Nullsv; + SV *sv = NULL; /* $stdlib = $HKCU{"lib-$]"} || $HKLM{"lib-$]"} || $HKCU{"lib"} || $HKLM{"lib"} || ""; */ sprintf(buffer, "%s-%s", stdlib, pl); @@ -369,17 +388,18 @@ win32_get_privlib(const char *pl) (void)get_regstr(stdlib, &sv); /* $stdlib .= ";$EMD/../../lib" */ - return get_emd_part(&sv, stdlib, ARCHNAME, "bin", Nullch); + 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]; char pathstr[MAX_PATH+1]; - SV *sv1 = Nullsv; - SV *sv2 = Nullsv; + SV *sv1 = NULL; + SV *sv2 = NULL; /* $HKCU{"$xlib-$]"} || $HKLM{"$xlib-$]"} . ---; */ sprintf(regstr, "%s-%s", xlib, pl); @@ -388,7 +408,7 @@ win32_get_xlib(const char *pl, const char *xlib, const char *libname) /* $xlib .= * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/$]/lib"; */ sprintf(pathstr, "%s/%s/lib", libname, pl); - (void)get_emd_part(&sv1, pathstr, ARCHNAME, "bin", pl, Nullch); + (void)get_emd_part(&sv1, NULL, pathstr, ARCHNAME, "bin", pl, NULL); /* $HKCU{$xlib} || $HKLM{$xlib} . ---; */ (void)get_regstr(xlib, &sv2); @@ -396,25 +416,26 @@ win32_get_xlib(const char *pl, const char *xlib, const char *libname) /* $xlib .= * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/lib"; */ sprintf(pathstr, "%s/lib", libname); - (void)get_emd_part(&sv2, pathstr, ARCHNAME, "bin", pl, Nullch); + (void)get_emd_part(&sv2, NULL, pathstr, ARCHNAME, "bin", pl, NULL); if (!sv1 && !sv2) - return Nullch; - if (!sv1) - return SvPVX(sv2); - if (!sv2) - return SvPVX(sv1); - - sv_catpvn(sv1, ";", 1); - sv_catsv(sv1, sv2); + return NULL; + 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 @@ -422,9 +443,9 @@ win32_get_sitelib(const char *pl) #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 @@ -535,7 +556,7 @@ win32_getpid(void) static long tokenize(const char *str, char **dest, char ***destv) { - char *retstart = Nullch; + char *retstart = NULL; char **retvstart = 0; int items = -1; if (str) { @@ -570,7 +591,7 @@ tokenize(const char *str, char **dest, char ***destv) ++items; ret++; } - retvstart[items] = Nullch; + retvstart[items] = NULL; *ret++ = '\0'; *ret = '\0'; } @@ -609,6 +630,8 @@ Perl_do_aspawn(pTHX_ SV *really, SV **mark, SV **sp) int flag = P_WAIT; int index = 0; + PERL_ARGS_ASSERT_DO_ASPAWN; + if (sp <= mark) return -1; @@ -647,8 +670,7 @@ Perl_do_aspawn(pTHX_ SV *really, SV **mark, SV **sp) } 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) { @@ -714,7 +736,7 @@ do_spawn2(pTHX_ const char *cmd, int exectype) if (*s) *s++ = '\0'; } - *a = Nullch; + *a = NULL; if (argv[0]) { switch (exectype) { case EXECF_SPAWN: @@ -743,7 +765,7 @@ do_spawn2(pTHX_ const char *cmd, int exectype) while (++i < w32_perlshell_items) argv[i] = w32_perlshell_vec[i]; argv[i++] = (char *)cmd; - argv[i] = Nullch; + argv[i] = NULL; switch (exectype) { case EXECF_SPAWN: status = win32_spawnvp(P_WAIT, argv[0], @@ -761,8 +783,7 @@ do_spawn2(pTHX_ const char *cmd, int exectype) 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) { @@ -782,18 +803,24 @@ do_spawn2(pTHX_ const char *cmd, int exectype) 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; } @@ -843,7 +870,7 @@ win32_opendir(const char *filename) scanname[len] = '\0'; /* do the FindFirstFile call */ - if (IsWinNT()) { + if (IsWin2000()) { WCHAR wscanname[sizeof(scanname)]; MultiByteToWideChar(CP_ACP, 0, scanname, -1, wscanname, sizeof(wscanname)/sizeof(WCHAR)); dirp->handle = FindFirstFileW(PerlDir_mapW(wscanname), &wFindData); @@ -934,7 +961,7 @@ win32_readdir(DIR *dirp) /* finding the next file that matches the wildcard * (which should be all of them in this directory!). */ - if (IsWinNT()) { + if (IsWin2000()) { WIN32_FIND_DATAW wFindData; res = FindNextFileW(dirp->handle, &wFindData); if (res) { @@ -1203,7 +1230,7 @@ kill_process_tree_toolhelp(DWORD pid, int sig) int killed = 0; process_handle = OpenProcess(PROCESS_TERMINATE, FALSE, pid); - if (process_handle == INVALID_HANDLE_VALUE) + if (process_handle == NULL) return 0; killed += terminate_process(pid, process_handle, sig); @@ -1238,7 +1265,7 @@ kill_process_tree_sysinfo(SYSTEM_PROCESSES *process_info, DWORD pid, int sig) int killed = 0; process_handle = OpenProcess(PROCESS_TERMINATE, FALSE, pid); - if (process_handle == INVALID_HANDLE_VALUE) + if (process_handle == NULL) return 0; killed += terminate_process(pid, process_handle, sig); @@ -1293,7 +1320,8 @@ my_kill(int pid, int sig) return killpg(pid, -sig); process_handle = OpenProcess(PROCESS_TERMINATE, FALSE, pid); - if (process_handle != INVALID_HANDLE_VALUE) { + /* OpenProcess() returns NULL on error, *not* INVALID_HANDLE_VALUE */ + if (process_handle != NULL) { retval = terminate_process(pid, process_handle, sig); CloseHandle(process_handle); } @@ -1304,7 +1332,6 @@ DllExport int win32_kill(int pid, int sig) { dTHX; - HANDLE hProcess; long child; #ifdef USE_ITHREADS if (pid < 0) { @@ -1312,7 +1339,7 @@ win32_kill(int pid, int sig) child = find_pseudo_pid(-pid); if (child >= 0) { HWND hwnd = w32_pseudo_child_message_hwnds[child]; - hProcess = w32_pseudo_child_handles[child]; + HANDLE hProcess = w32_pseudo_child_handles[child]; switch (sig) { case 0: /* "Does process exist?" use of kill */ @@ -1333,6 +1360,7 @@ win32_kill(int pid, int sig) /* Yield and wait for the other thread to send us its message_hwnd */ Sleep(0); win32_async_check(aTHX); + hwnd = w32_pseudo_child_message_hwnds[child]; ++count; } if (hwnd != INVALID_HANDLE_VALUE) { @@ -1485,9 +1513,22 @@ win32_stat(const char *path, Stat_t *sbuf) 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] == '.') { @@ -1535,7 +1576,7 @@ win32_longpath(char *path) char *start = path; char sep; if (!path) - return Nullch; + return NULL; /* drive prefix */ if (isALPHA(path[0]) && path[1] == ':') { @@ -1599,14 +1640,14 @@ win32_longpath(char *path) else { FindClose(fhand); errno = ERANGE; - return Nullch; + return NULL; } } else { /* failed a step, just return without side effects */ /*PerlIO_printf(Perl_debug_log, "Failed to find %s\n", path);*/ errno = EINVAL; - return Nullch; + return NULL; } } strcpy(path,tmpbuf); @@ -1614,7 +1655,7 @@ win32_longpath(char *path) } static void -out_of_memory() +out_of_memory(void) { if (PL_curinterp) { dTHX; @@ -1683,7 +1724,7 @@ win32_getenv(const char *name) { dTHX; DWORD needlen; - SV *curitem = Nullsv; + SV *curitem = NULL; needlen = GetEnvironmentVariableA(name,NULL,0); if (needlen != 0) { @@ -1704,7 +1745,7 @@ win32_getenv(const char *name) if (curitem && SvCUR(curitem)) return SvPVX(curitem); - return Nullch; + return NULL; } DllExport int @@ -1724,9 +1765,11 @@ win32_putenv(const char *name) * 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 @@ -2067,68 +2110,47 @@ win32_async_check(pTHX) MSG msg; HWND hwnd = w32_message_hwnd; + /* Reset w32_poll_count before doing anything else, incase we dispatch + * messages that end up calling back into perl */ w32_poll_count = 0; - if (hwnd == INVALID_HANDLE_VALUE) { - /* Call PeekMessage() to mark all pending messages in the queue as "old". - * This is necessary when we are being called by win32_msgwait() to - * make sure MsgWaitForMultipleObjects() stops reporting the same waiting - * message over and over. An example how this can happen is when - * Perl is calling win32_waitpid() inside a GUI application and the GUI - * is generating messages before the process terminated. - */ - PeekMessage(&msg, NULL, 0, 0, PM_NOREMOVE|PM_NOYIELD); - if (PL_sig_pending) - despatch_signals(); - return 1; - } - - /* Passing PeekMessage -1 as HWND (2nd arg) only get PostThreadMessage() messages - * and ignores window messages - should co-exist better with windows apps e.g. Tk - */ - if (hwnd == NULL) - hwnd = (HWND)-1; - - while (PeekMessage(&msg, hwnd, WM_TIMER, WM_TIMER, PM_REMOVE|PM_NOYIELD) || - PeekMessage(&msg, hwnd, WM_USER_MIN, WM_USER_MAX, PM_REMOVE|PM_NOYIELD)) - { - switch (msg.message) { -#ifdef USE_ITHREADS - case WM_USER_MESSAGE: { - int child = find_pseudo_pid(msg.wParam); - if (child >= 0) - w32_pseudo_child_message_hwnds[child] = (HWND)msg.lParam; - break; - } -#endif - - case WM_USER_KILL: { - /* We use WM_USER to fake kill() with other signals */ - int sig = msg.wParam; - if (do_raise(aTHX_ sig)) - sig_terminate(aTHX_ sig); - break; - } - - case WM_TIMER: { - /* alarm() is a one-shot but SetTimer() repeats so kill it */ - if (w32_timerid && w32_timerid==msg.wParam) { - KillTimer(w32_message_hwnd, w32_timerid); - w32_timerid=0; + if (hwnd != INVALID_HANDLE_VALUE) { + /* Passing PeekMessage -1 as HWND (2nd arg) only gets PostThreadMessage() messages + * and ignores window messages - should co-exist better with windows apps e.g. Tk + */ + if (hwnd == NULL) + hwnd = (HWND)-1; + + while (PeekMessage(&msg, hwnd, WM_TIMER, WM_TIMER, PM_REMOVE|PM_NOYIELD) || + PeekMessage(&msg, hwnd, WM_USER_MIN, WM_USER_MAX, PM_REMOVE|PM_NOYIELD)) + { + /* re-post a WM_QUIT message (we'll mark it as read later) */ + if(msg.message == WM_QUIT) { + PostQuitMessage((int)msg.wParam); + break; + } - /* Now fake a call to signal handler */ - if (do_raise(aTHX_ 14)) - sig_terminate(aTHX_ 14); + if(!CallMsgFilter(&msg, MSGF_USER)) + { + TranslateMessage(&msg); + DispatchMessage(&msg); } - break; - } - } /* switch */ + } } + /* Call PeekMessage() to mark all pending messages in the queue as "old". + * This is necessary when we are being called by win32_msgwait() to + * make sure MsgWaitForMultipleObjects() stops reporting the same waiting + * message over and over. An example how this can happen is when + * Perl is calling win32_waitpid() inside a GUI application and the GUI + * is generating messages before the process terminated. + */ + PeekMessage(&msg, NULL, 0, 0, PM_NOREMOVE|PM_NOYIELD); + /* Above or other stuff may have set a signal flag */ - if (PL_sig_pending) { - despatch_signals(); - } + if (PL_sig_pending) + despatch_signals(); + return 1; } @@ -2144,7 +2166,7 @@ win32_msgwait(pTHX_ DWORD count, LPHANDLE handles, DWORD timeout, LPDWORD result timeout += ticks; } while (1) { - DWORD result = MsgWaitForMultipleObjects(count,handles,FALSE,timeout-ticks, QS_ALLEVENTS); + DWORD result = MsgWaitForMultipleObjects(count,handles,FALSE,timeout-ticks, QS_POSTMESSAGE|QS_TIMER|QS_SENDMESSAGE); if (resultp) *resultp = result; if (result == WAIT_TIMEOUT) { @@ -2375,7 +2397,7 @@ win32_crypt(const char *txt, const char *salt) return des_fcrypt(txt, salt, w32_crypt_buffer); #else Perl_croak(aTHX_ "The crypt() function is unimplemented due to excessive paranoia."); - return Nullch; + return NULL; #endif } @@ -2548,7 +2570,7 @@ win32_stdin(void) } DllExport FILE * -win32_stdout() +win32_stdout(void) { return (stdout); } @@ -2930,7 +2952,7 @@ win32_fstat(int fd, Stat_t *sbufptr) 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) @@ -3254,7 +3276,7 @@ win32_rename(const char *oname, const char *newname) int retval = 0; char szTmpName[MAX_PATH+1]; char dname[MAX_PATH+1]; - char *endname = Nullch; + char *endname = NULL; STRLEN tmplen = 0; DWORD from_attr, to_attr; @@ -3313,7 +3335,7 @@ win32_rename(const char *oname, const char *newname) retval = rename(szOldName, szNewName); /* if we created a temporary file before ... */ - if (endname != Nullch) { + if (endname != NULL) { /* ...and rename succeeded, delete temporary file/directory */ if (retval == 0) DeleteFile(szTmpName); @@ -3895,7 +3917,7 @@ qualified_path(const char *cmd) int has_slash = 0; if (!cmd) - return Nullch; + return NULL; fullcmd = (char*)cmd; while (*fullcmd) { if (*fullcmd == '/' || *fullcmd == '\\') @@ -3969,7 +3991,7 @@ qualified_path(const char *cmd) } Safefree(fullcmd); - return Nullch; + return NULL; } /* The following are just place holders. @@ -4056,7 +4078,7 @@ win32_spawnvp(int mode, const char *cmdname, const char *const *argv) PROCESS_INFORMATION ProcessInformation; DWORD create = 0; char *cmd; - char *fullcmd = Nullch; + char *fullcmd = NULL; char *cname = (char *)cmdname; STRLEN clen = 0; @@ -4562,73 +4584,23 @@ XS(w32_SetChildShowWindow) XSRETURN(1); } -static void -forward(pTHX_ const char *function) -{ - dXSARGS; - Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn("Win32",5), newSVnv(0.27)); - SPAGAIN; - PUSHMARK(SP-items); - call_pv(function, GIMME_V); -} - -#define FORWARD(function) XS(w32_##function){ forward(aTHX_ "Win32::"#function); } -FORWARD(GetCwd) -FORWARD(SetCwd) -FORWARD(GetNextAvailDrive) -FORWARD(GetLastError) -FORWARD(SetLastError) -FORWARD(LoginName) -FORWARD(NodeName) -FORWARD(DomainName) -FORWARD(FsType) -FORWARD(GetOSVersion) -FORWARD(IsWinNT) -FORWARD(IsWin95) -FORWARD(FormatMessage) -FORWARD(Spawn) -FORWARD(GetTickCount) -FORWARD(GetShortPathName) -FORWARD(GetFullPathName) -FORWARD(GetLongPathName) -FORWARD(CopyFile) -FORWARD(Sleep) - -/* Don't forward Win32::SetChildShowWindow(). It accesses the internal variable - * w32_showwindow in thread_intern and is therefore not implemented in Win32.xs. - */ -/* FORWARD(SetChildShowWindow) */ - -#undef FORWARD - void Perl_init_os_extras(void) { dTHX; char *file = __FILE__; - dXSUB_SYS; - - /* these names are Activeware compatible */ - newXS("Win32::GetCwd", w32_GetCwd, file); - newXS("Win32::SetCwd", w32_SetCwd, file); - newXS("Win32::GetNextAvailDrive", w32_GetNextAvailDrive, file); - newXS("Win32::GetLastError", w32_GetLastError, file); - newXS("Win32::SetLastError", w32_SetLastError, file); - newXS("Win32::LoginName", w32_LoginName, file); - newXS("Win32::NodeName", w32_NodeName, file); - newXS("Win32::DomainName", w32_DomainName, file); - newXS("Win32::FsType", w32_FsType, file); - newXS("Win32::GetOSVersion", w32_GetOSVersion, file); - newXS("Win32::IsWinNT", w32_IsWinNT, file); - newXS("Win32::IsWin95", w32_IsWin95, file); - newXS("Win32::FormatMessage", w32_FormatMessage, file); - newXS("Win32::Spawn", w32_Spawn, file); - newXS("Win32::GetTickCount", w32_GetTickCount, file); - newXS("Win32::GetShortPathName", w32_GetShortPathName, file); - newXS("Win32::GetFullPathName", w32_GetFullPathName, file); - newXS("Win32::GetLongPathName", w32_GetLongPathName, file); - newXS("Win32::CopyFile", w32_CopyFile, file); - newXS("Win32::Sleep", w32_Sleep, file); + + /* Initialize Win32CORE if it has been statically linked. */ + void (*pfn_init)(pTHX); +#if defined(__BORLANDC__) + /* makedef.pl seems to have given up on fixing this issue in the .def file */ + pfn_init = (void (*)(pTHX))GetProcAddress((HMODULE)w32_perldll_handle, "_init_Win32CORE"); +#else + pfn_init = (void (*)(pTHX))GetProcAddress((HMODULE)w32_perldll_handle, "init_Win32CORE"); +#endif + if (pfn_init) + pfn_init(aTHX); + newXS("Win32::SetChildShowWindow", w32_SetChildShowWindow, file); } @@ -4701,99 +4673,20 @@ win32_ctrlhandler(DWORD dwCtrlType) } -#if _MSC_VER >= 1400 +#ifdef SET_INVALID_PARAMETER_HANDLER # include #endif -void -Perl_win32_init(int *argcp, char ***argvp) -{ - HMODULE module; - -#if _MSC_VER >= 1400 - _invalid_parameter_handler oldHandler, newHandler; - newHandler = my_invalid_parameter_handler; - oldHandler = _set_invalid_parameter_handler(newHandler); - _CrtSetReportMode(_CRT_ASSERT, 0); -#endif - /* Disable floating point errors, Perl will trap the ones we - * care about. VC++ RTL defaults to switching these off - * already, but the Borland RTL doesn't. Since we don't - * want to be at the vendor's whim on the default, we set - * it explicitly here. - */ -#if !defined(_ALPHA_) && !defined(__GNUC__) - _control87(MCW_EM, MCW_EM); -#endif - MALLOC_INIT; - - module = GetModuleHandle("ntdll.dll"); - if (module) { - *(FARPROC*)&pfnZwQuerySystemInformation = GetProcAddress(module, "ZwQuerySystemInformation"); - } - - module = GetModuleHandle("kernel32.dll"); - if (module) { - *(FARPROC*)&pfnCreateToolhelp32Snapshot = GetProcAddress(module, "CreateToolhelp32Snapshot"); - *(FARPROC*)&pfnProcess32First = GetProcAddress(module, "Process32First"); - *(FARPROC*)&pfnProcess32Next = GetProcAddress(module, "Process32Next"); - } -} - -void -Perl_win32_term(void) -{ - dTHX; - HINTS_REFCNT_TERM; - OP_REFCNT_TERM; - PERLIO_TERM; - MALLOC_TERM; -} - -void -win32_get_child_IO(child_IO_table* ptbl) -{ - ptbl->childStdIn = GetStdHandle(STD_INPUT_HANDLE); - ptbl->childStdOut = GetStdHandle(STD_OUTPUT_HANDLE); - ptbl->childStdErr = GetStdHandle(STD_ERROR_HANDLE); -} - -Sighandler_t -win32_signal(int sig, Sighandler_t subcode) -{ - dTHX; - if (sig < SIG_SIZE) { - int save_errno = errno; - Sighandler_t result = signal(sig, subcode); - if (result == SIG_ERR) { - result = w32_sighandler[sig]; - errno = save_errno; - } - w32_sighandler[sig] = subcode; - return result; - } - else { - errno = EINVAL; - return SIG_ERR; - } -} - - -#ifdef HAVE_INTERP_INTERN - static void ansify_path(void) { - OSVERSIONINFO osver; /* g_osver may not yet be initialized */ size_t len; char *ansi_path; WCHAR *wide_path; WCHAR *wide_dir; - /* there is no Unicode environment on Windows 9X */ - osver.dwOSVersionInfoSize = sizeof(osver); - GetVersionEx(&osver); - if (osver.dwPlatformId == VER_PLATFORM_WIN32_WINDOWS) + /* win32_ansipath() requires Windows 2000 or later */ + if (!IsWin2000()) return; /* fetch Unicode version of PATH */ @@ -4871,24 +4764,221 @@ ansify_path(void) * will not call mg_set() if it initializes %ENV from `environ`. */ SetEnvironmentVariableA("PATH", ansi_path+5); - win32_free(ansi_path); + /* We are intentionally leaking the ansi_path string here because + * the Borland runtime library puts it directly into the environ + * array. The Microsoft runtime library seems to make a copy, + * but will leak the copy should it be replaced again later. + * Since this code is only called once during PERL_SYS_INIT this + * shouldn't really matter. + */ } win32_free(wide_path); } -static void -win32_csighandler(int sig) +void +Perl_win32_init(int *argcp, char ***argvp) { -#if 0 - dTHXa(PERL_GET_SIG_CONTEXT); - Perl_warn(aTHX_ "Got signal %d",sig); + HMODULE module; + +#ifdef SET_INVALID_PARAMETER_HANDLER + _invalid_parameter_handler oldHandler, newHandler; + newHandler = my_invalid_parameter_handler; + oldHandler = _set_invalid_parameter_handler(newHandler); + _CrtSetReportMode(_CRT_ASSERT, 0); #endif - /* Does nothing */ + /* Disable floating point errors, Perl will trap the ones we + * care about. VC++ RTL defaults to switching these off + * already, but the Borland RTL doesn't. Since we don't + * want to be at the vendor's whim on the default, we set + * it explicitly here. + */ +#if !defined(_ALPHA_) && !defined(__GNUC__) + _control87(MCW_EM, MCW_EM); +#endif + MALLOC_INIT; + + module = GetModuleHandle("ntdll.dll"); + if (module) { + *(FARPROC*)&pfnZwQuerySystemInformation = GetProcAddress(module, "ZwQuerySystemInformation"); + } + + module = GetModuleHandle("kernel32.dll"); + if (module) { + *(FARPROC*)&pfnCreateToolhelp32Snapshot = GetProcAddress(module, "CreateToolhelp32Snapshot"); + *(FARPROC*)&pfnProcess32First = GetProcAddress(module, "Process32First"); + *(FARPROC*)&pfnProcess32Next = GetProcAddress(module, "Process32Next"); + } + + g_osver.dwOSVersionInfoSize = sizeof(g_osver); + GetVersionEx(&g_osver); + + ansify_path(); +} + +void +Perl_win32_term(void) +{ + dTHX; + HINTS_REFCNT_TERM; + OP_REFCNT_TERM; + PERLIO_TERM; + MALLOC_TERM; +} + +void +win32_get_child_IO(child_IO_table* ptbl) +{ + ptbl->childStdIn = GetStdHandle(STD_INPUT_HANDLE); + ptbl->childStdOut = GetStdHandle(STD_OUTPUT_HANDLE); + ptbl->childStdErr = GetStdHandle(STD_ERROR_HANDLE); +} + +Sighandler_t +win32_signal(int sig, Sighandler_t subcode) +{ + dTHX; + if (sig < SIG_SIZE) { + int save_errno = errno; + Sighandler_t result = signal(sig, subcode); + if (result == SIG_ERR) { + result = w32_sighandler[sig]; + errno = save_errno; + } + w32_sighandler[sig] = subcode; + return result; + } + else { + errno = EINVAL; + return SIG_ERR; + } +} + +/* The PerlMessageWindowClass's WindowProc */ +LRESULT CALLBACK +win32_message_window_proc(HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam) +{ + return win32_process_message(hwnd, msg, wParam, lParam) ? + 0 : DefWindowProc(hwnd, msg, wParam, lParam); +} + +/* we use a message filter hook to process thread messages, passing any + * messages that we don't process on to the rest of the hook chain + * Anyone else writing a message loop that wants to play nicely with perl + * should do + * CallMsgFilter(&msg, MSGF_***); + * between their GetMessage and DispatchMessage calls. */ +LRESULT CALLBACK +win32_message_filter_proc(int code, WPARAM wParam, LPARAM lParam) { + LPMSG pmsg = (LPMSG)lParam; + + /* we'll process it if code says we're allowed, and it's a thread message */ + if (code >= 0 && pmsg->hwnd == NULL + && win32_process_message(pmsg->hwnd, pmsg->message, + pmsg->wParam, pmsg->lParam)) + { + return TRUE; + } + + /* XXX: MSDN says that hhk is ignored, but we should really use the + * return value from SetWindowsHookEx() in win32_create_message_window(). */ + return CallNextHookEx(NULL, code, wParam, lParam); +} + +/* The real message handler. Can be called with + * hwnd == NULL to process our thread messages. Returns TRUE for any messages + * that it processes */ +static LRESULT +win32_process_message(HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam) +{ + /* BEWARE. The context retrieved using dTHX; is the context of the + * 'parent' thread during the CreateWindow() phase - i.e. for all messages + * up to and including WM_CREATE. If it ever happens that you need the + * 'child' context before this, then it needs to be passed into + * win32_create_message_window(), and passed to the WM_NCCREATE handler + * from the lparam of CreateWindow(). It could then be stored/retrieved + * using [GS]etWindowLongPtr(... GWLP_USERDATA ...), possibly eliminating + * the dTHX calls here. */ + /* XXX For now it is assumed that the overhead of the dTHX; for what + * are relativley infrequent code-paths, is better than the added + * complexity of getting the correct context passed into + * win32_create_message_window() */ + + switch(msg) { + +#ifdef USE_ITHREADS + case WM_USER_MESSAGE: { + long child = find_pseudo_pid((int)wParam); + if (child >= 0) { + dTHX; + w32_pseudo_child_message_hwnds[child] = (HWND)lParam; + return 1; + } + break; + } +#endif + + case WM_USER_KILL: { + dTHX; + /* We use WM_USER_KILL to fake kill() with other signals */ + int sig = (int)wParam; + if (do_raise(aTHX_ sig)) + sig_terminate(aTHX_ sig); + + return 1; + } + + case WM_TIMER: { + dTHX; + /* alarm() is a one-shot but SetTimer() repeats so kill it */ + if (w32_timerid && w32_timerid==(UINT)wParam) { + KillTimer(w32_message_hwnd, w32_timerid); + w32_timerid=0; + + /* Now fake a call to signal handler */ + if (do_raise(aTHX_ 14)) + sig_terminate(aTHX_ 14); + + return 1; + } + break; + } + + default: + break; + + } /* switch */ + + /* Above or other stuff may have set a signal flag, and we may not have + * been called from win32_async_check() (e.g. some other GUI's message + * loop. BUT DON'T dispatch signals here: If someone has set a SIGALRM + * handler that die's, and the message loop that calls here is wrapped + * in an eval, then you may well end up with orphaned windows - signals + * are dispatched by win32_async_check() */ + + return 0; +} + +void +win32_create_message_window_class(void) +{ + /* create the window class for "message only" windows */ + WNDCLASS wc; + + Zero(&wc, 1, wc); + wc.lpfnWndProc = win32_message_window_proc; + wc.hInstance = (HINSTANCE)GetModuleHandle(NULL); + wc.lpszClassName = "PerlMessageWindowClass"; + + /* second and subsequent calls will fail, but class + * will already be registered */ + RegisterClass(&wc); } HWND -win32_create_message_window() +win32_create_message_window(void) { + HWND hwnd = NULL; + /* "message-only" windows have been implemented in Windows 2000 and later. * On earlier versions we'll continue to post messages to a specific * thread and use hwnd==NULL. This is brittle when either an embedding @@ -4897,10 +4987,42 @@ win32_create_message_window() * "right" place with DispatchMessage() anymore, as there is no WindowProc * if there is no window handle. */ - if (g_osver.dwMajorVersion < 5) - return NULL; + /* Using HWND_MESSAGE appears to work under Win98, despite MSDN + * documentation to the contrary, however, there is some evidence that + * there may be problems with the implementation on Win98. As it is not + * officially supported we take the cautious route and stick with thread + * messages (hwnd == NULL) on platforms prior to Win2k. + */ + if (IsWin2000()) { + win32_create_message_window_class(); - return CreateWindow("Static", "", 0, 0, 0, 0, 0, HWND_MESSAGE, 0, 0, NULL); + hwnd = CreateWindow("PerlMessageWindowClass", "PerlMessageWindow", + 0, 0, 0, 0, 0, HWND_MESSAGE, NULL, NULL, NULL); + } + + /* If we din't create a window for any reason, then we'll use thread + * messages for our signalling, so we install a hook which + * is called by CallMsgFilter in win32_async_check(), or any other + * modal loop (e.g. Win32::MsgBox or any other GUI extention, or anything + * that use OLE, etc. */ + if(!hwnd) { + SetWindowsHookEx(WH_MSGFILTER, win32_message_filter_proc, + NULL, GetCurrentThreadId()); + } + + return hwnd; +} + +#ifdef HAVE_INTERP_INTERN + +static void +win32_csighandler(int sig) +{ +#if 0 + dTHXa(PERL_GET_SIG_CONTEXT); + Perl_warn(aTHX_ "Got signal %d",sig); +#endif + /* Does nothing */ } #if defined(__MINGW32__) && defined(__cplusplus) @@ -4914,12 +5036,7 @@ Perl_sys_intern_init(pTHX) { int i; - if (g_osver.dwOSVersionInfoSize == 0) { - g_osver.dwOSVersionInfoSize = sizeof(g_osver); - GetVersionEx(&g_osver); - } - - w32_perlshell_tokens = Nullch; + w32_perlshell_tokens = NULL; w32_perlshell_vec = (char**)NULL; w32_perlshell_items = 0; w32_fdpid = newAV(); @@ -4936,7 +5053,7 @@ Perl_sys_intern_init(pTHX) for (i=0; i < SIG_SIZE; i++) { w32_sighandler[i] = SIG_DFL; } -# ifdef MULTIPLICTY +# ifdef MULTIPLICITY if (my_perl == PL_curinterp) { # else { @@ -4944,11 +5061,19 @@ Perl_sys_intern_init(pTHX) /* Force C runtime signal stuff to set its console handler */ signal(SIGINT,win32_csighandler); signal(SIGBREAK,win32_csighandler); + + /* We spawn asynchronous processes with the CREATE_NEW_PROCESS_GROUP + * flag. This has the side-effect of disabling Ctrl-C events in all + * processes in this group. At least on Windows NT and later we + * can re-enable Ctrl-C handling by calling SetConsoleCtrlHandler() + * with a NULL handler. This is not valid on Windows 9X. + */ + if (IsWinNT()) + SetConsoleCtrlHandler(NULL,FALSE); + /* Push our handler on top */ SetConsoleCtrlHandler(win32_ctrlhandler,TRUE); } - - ansify_path(); } void @@ -4981,7 +5106,9 @@ Perl_sys_intern_clear(pTHX) void Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst) { - dst->perlshell_tokens = Nullch; + PERL_ARGS_ASSERT_SYS_INTERN_DUP; + + dst->perlshell_tokens = NULL; dst->perlshell_vec = (char**)NULL; dst->perlshell_items = 0; dst->fdpid = newAV(); @@ -4995,32 +5122,3 @@ Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst) } # endif /* USE_ITHREADS */ #endif /* HAVE_INTERP_INTERN */ - -static void -win32_free_argvw(pTHX_ void *ptr) -{ - char** argv = (char**)ptr; - while(*argv) { - Safefree(*argv); - *argv++ = Nullch; - } -} - -void -win32_argv2utf8(int argc, char** argv) -{ - dTHX; - char* psz; - int length, wargc; - LPWSTR* lpwStr = CommandLineToArgvW(GetCommandLineW(), &wargc); - if (lpwStr && argc) { - while (argc--) { - length = WideCharToMultiByte(CP_UTF8, 0, lpwStr[--wargc], -1, NULL, 0, NULL, NULL); - Newxz(psz, length, char); - WideCharToMultiByte(CP_UTF8, 0, lpwStr[wargc], -1, psz, length, NULL, NULL); - argv[argc] = psz; - } - call_atexit(win32_free_argvw, argv); - } - GlobalFree((HGLOBAL)lpwStr); -}