879b6130dd521b1b2062e8781cc848183603b540
[perl.git] / win32 / win32.c
1 /* WIN32.C
2  *
3  * (c) 1995 Microsoft Corporation. All rights reserved.
4  *              Developed by hip communications inc.
5  * Portions (c) 1993 Intergraph Corporation. All rights reserved.
6  *
7  *    You may distribute under the terms of either the GNU General Public
8  *    License or the Artistic License, as specified in the README file.
9  */
10 #define PERLIO_NOT_STDIO 0
11 #define WIN32_LEAN_AND_MEAN
12 #define WIN32IO_IS_STDIO
13 #include <tchar.h>
14
15 #ifdef __GNUC__
16 #  define Win32_Winsock
17 #endif
18
19 #ifndef _WIN32_WINNT
20 #  define _WIN32_WINNT 0x0500     /* needed for CreateHardlink() etc. */
21 #endif
22
23 #include <windows.h>
24
25 #ifndef HWND_MESSAGE
26 #  define HWND_MESSAGE ((HWND)-3)
27 #endif
28
29 #ifndef PROCESSOR_ARCHITECTURE_AMD64
30 #  define PROCESSOR_ARCHITECTURE_AMD64 9
31 #endif
32
33 #ifndef WC_NO_BEST_FIT_CHARS
34 #  define WC_NO_BEST_FIT_CHARS 0x00000400
35 #endif
36
37 #include <winnt.h>
38 #include <commctrl.h>
39 #include <tlhelp32.h>
40 #include <io.h>
41 #include <signal.h>
42
43 /* #include "config.h" */
44
45 #if !defined(PERLIO_IS_STDIO)
46 #  define PerlIO FILE
47 #endif
48
49 #include <sys/stat.h>
50 #include "EXTERN.h"
51 #include "perl.h"
52
53 #define NO_XSLOCKS
54 #define PERL_NO_GET_CONTEXT
55 #include "XSUB.h"
56
57 #include <fcntl.h>
58 #ifndef __GNUC__
59 /* assert.h conflicts with #define of assert in perl.h */
60 #  include <assert.h>
61 #endif
62
63 #include <string.h>
64 #include <stdarg.h>
65 #include <float.h>
66 #include <time.h>
67 #include <sys/utime.h>
68
69 #ifdef __GNUC__
70 /* Mingw32 defaults to globing command line
71  * So we turn it off like this:
72  */
73 int _CRT_glob = 0;
74 #endif
75
76 #if defined(__MINGW32__) && (__MINGW32_MAJOR_VERSION==1)        
77 /* Mingw32-1.1 is missing some prototypes */
78 START_EXTERN_C
79 FILE * _wfopen(LPCWSTR wszFileName, LPCWSTR wszMode);
80 FILE * _wfdopen(int nFd, LPCWSTR wszMode);
81 FILE * _freopen(LPCWSTR wszFileName, LPCWSTR wszMode, FILE * pOldStream);
82 int _flushall();
83 int _fcloseall();
84 END_EXTERN_C
85 #endif
86
87 #define EXECF_EXEC 1
88 #define EXECF_SPAWN 2
89 #define EXECF_SPAWN_NOWAIT 3
90
91 #if defined(PERL_IMPLICIT_SYS)
92 #  undef win32_get_privlib
93 #  define win32_get_privlib g_win32_get_privlib
94 #  undef win32_get_sitelib
95 #  define win32_get_sitelib g_win32_get_sitelib
96 #  undef win32_get_vendorlib
97 #  define win32_get_vendorlib g_win32_get_vendorlib
98 #  undef getlogin
99 #  define getlogin g_getlogin
100 #endif
101
102 /* VS2005 (MSC version 14) provides a mechanism to set an invalid
103  * parameter handler.  This functionality is not available in the
104  * 64-bit compiler from the Platform SDK, which unfortunately also
105  * believes itself to be MSC version 14.
106  *
107  * There is no #define related to _set_invalid_parameter_handler(),
108  * but we can check for one of the constants defined for
109  * _set_abort_behavior(), which was introduced into stdlib.h at
110  * the same time.
111  */
112
113 #if _MSC_VER >= 1400 && defined(_WRITE_ABORT_MSG)
114 #  define SET_INVALID_PARAMETER_HANDLER
115 #endif
116
117 #ifdef SET_INVALID_PARAMETER_HANDLER
118 static BOOL     set_silent_invalid_parameter_handler(BOOL newvalue);
119 static void     my_invalid_parameter_handler(const wchar_t* expression,
120                         const wchar_t* function, const wchar_t* file,
121                         unsigned int line, uintptr_t pReserved);
122 #endif
123
124 static char*    get_regstr_from(HKEY hkey, const char *valuename, SV **svp);
125 static char*    get_regstr(const char *valuename, SV **svp);
126 static char*    get_emd_part(SV **prev_pathp, STRLEN *const len,
127                         char *trailing, ...);
128 static char*    win32_get_xlib(const char *pl, const char *xlib,
129                         const char *libname, STRLEN *const len);
130 static BOOL     has_shell_metachars(const char *ptr);
131 static long     tokenize(const char *str, char **dest, char ***destv);
132 static void     get_shell(void);
133 static char*    find_next_space(const char *s);
134 static int      do_spawn2(pTHX_ const char *cmd, int exectype);
135 static int      do_spawn2_handles(pTHX_ const char *cmd, int exectype,
136                         const int *handles);
137 static int      do_spawnvp_handles(int mode, const char *cmdname,
138                         const char * const *argv, const int *handles);
139 static PerlIO * do_popen(const char *mode, const char *command, IV narg,
140                          SV **args);
141 static long     find_pid(pTHX_ int pid);
142 static void     remove_dead_process(long child);
143 static int      terminate_process(DWORD pid, HANDLE process_handle, int sig);
144 static int      my_killpg(int pid, int sig);
145 static int      my_kill(int pid, int sig);
146 static void     out_of_memory(void);
147 static char*    wstr_to_str(const wchar_t* wstr);
148 static long     filetime_to_clock(PFILETIME ft);
149 static BOOL     filetime_from_time(PFILETIME ft, time_t t);
150 static char*    create_command_line(char *cname, STRLEN clen,
151                                     const char * const *args);
152 static char*    qualified_path(const char *cmd, bool other_exts);
153 static void     ansify_path(void);
154 static LRESULT  win32_process_message(HWND hwnd, UINT msg,
155                         WPARAM wParam, LPARAM lParam);
156
157 #ifdef USE_ITHREADS
158 static long     find_pseudo_pid(pTHX_ int pid);
159 static void     remove_dead_pseudo_process(long child);
160 static HWND     get_hwnd_delay(pTHX, long child, DWORD tries);
161 #endif
162
163 #ifdef HAVE_INTERP_INTERN
164 static void     win32_csighandler(int sig);
165 #endif
166
167 START_EXTERN_C
168 HANDLE  w32_perldll_handle = INVALID_HANDLE_VALUE;
169 char    w32_module_name[MAX_PATH+1];
170 #ifdef WIN32_DYN_IOINFO_SIZE
171 Size_t  w32_ioinfo_size;/* avoid 0 extend op b4 mul, otherwise could be a U8 */
172 #endif
173 END_EXTERN_C
174
175 static OSVERSIONINFO g_osver = {0, 0, 0, 0, 0, ""};
176
177 #ifdef SET_INVALID_PARAMETER_HANDLER
178 static BOOL silent_invalid_parameter_handler = FALSE;
179
180 static BOOL
181 set_silent_invalid_parameter_handler(BOOL newvalue)
182 {
183     BOOL oldvalue = silent_invalid_parameter_handler;
184 #  ifdef _DEBUG
185     silent_invalid_parameter_handler = newvalue;
186 #  endif
187     return oldvalue;
188 }
189
190 static void
191 my_invalid_parameter_handler(const wchar_t* expression,
192     const wchar_t* function, 
193     const wchar_t* file, 
194     unsigned int line, 
195     uintptr_t pReserved)
196 {
197 #  ifdef _DEBUG
198     char* ansi_expression;
199     char* ansi_function;
200     char* ansi_file;
201     if (silent_invalid_parameter_handler)
202         return;
203     ansi_expression = wstr_to_str(expression);
204     ansi_function = wstr_to_str(function);
205     ansi_file = wstr_to_str(file);
206     fprintf(stderr, "Invalid parameter detected in function %s. "
207                     "File: %s, line: %d\n", ansi_function, ansi_file, line);
208     fprintf(stderr, "Expression: %s\n", ansi_expression);
209     free(ansi_expression);
210     free(ansi_function);
211     free(ansi_file);
212 #  endif
213 }
214 #endif
215
216 EXTERN_C void
217 set_w32_module_name(void)
218 {
219     /* this function may be called at DLL_PROCESS_ATTACH time */
220     char* ptr;
221     HMODULE module = (HMODULE)((w32_perldll_handle == INVALID_HANDLE_VALUE)
222                                ? GetModuleHandle(NULL)
223                                : w32_perldll_handle);
224
225     WCHAR modulename[MAX_PATH];
226     WCHAR fullname[MAX_PATH];
227     char *ansi;
228
229     DWORD (__stdcall *pfnGetLongPathNameW)(LPCWSTR, LPWSTR, DWORD) =
230         (DWORD (__stdcall *)(LPCWSTR, LPWSTR, DWORD))
231         GetProcAddress(GetModuleHandle("kernel32.dll"), "GetLongPathNameW");
232
233     GetModuleFileNameW(module, modulename, sizeof(modulename)/sizeof(WCHAR));
234
235     /* Make sure we get an absolute pathname in case the module was loaded
236      * explicitly by LoadLibrary() with a relative path. */
237     GetFullPathNameW(modulename, sizeof(fullname)/sizeof(WCHAR), fullname, NULL);
238
239     /* Make sure we start with the long path name of the module because we
240      * later scan for pathname components to match "5.xx" to locate
241      * compatible sitelib directories, and the short pathname might mangle
242      * this path segment (e.g. by removing the dot on NTFS to something
243      * like "5xx~1.yy") */
244     if (pfnGetLongPathNameW)
245         pfnGetLongPathNameW(fullname, fullname, sizeof(fullname)/sizeof(WCHAR));
246
247     /* remove \\?\ prefix */
248     if (memcmp(fullname, L"\\\\?\\", 4*sizeof(WCHAR)) == 0)
249         memmove(fullname, fullname+4, (wcslen(fullname+4)+1)*sizeof(WCHAR));
250
251     ansi = win32_ansipath(fullname);
252     my_strlcpy(w32_module_name, ansi, sizeof(w32_module_name));
253     win32_free(ansi);
254
255     /* normalize to forward slashes */
256     ptr = w32_module_name;
257     while (*ptr) {
258         if (*ptr == '\\')
259             *ptr = '/';
260         ++ptr;
261     }
262 }
263
264 /* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
265 static char*
266 get_regstr_from(HKEY hkey, const char *valuename, SV **svp)
267 {
268     /* Retrieve a REG_SZ or REG_EXPAND_SZ from the registry */
269     HKEY handle;
270     DWORD type;
271     const char *subkey = "Software\\Perl";
272     char *str = NULL;
273     long retval;
274
275     retval = RegOpenKeyEx(hkey, subkey, 0, KEY_READ, &handle);
276     if (retval == ERROR_SUCCESS) {
277         DWORD datalen;
278         retval = RegQueryValueEx(handle, valuename, 0, &type, NULL, &datalen);
279         if (retval == ERROR_SUCCESS
280             && (type == REG_SZ || type == REG_EXPAND_SZ))
281         {
282             dTHX;
283             if (!*svp)
284                 *svp = sv_2mortal(newSVpvs(""));
285             SvGROW(*svp, datalen);
286             retval = RegQueryValueEx(handle, valuename, 0, NULL,
287                                      (PBYTE)SvPVX(*svp), &datalen);
288             if (retval == ERROR_SUCCESS) {
289                 str = SvPVX(*svp);
290                 SvCUR_set(*svp,datalen-1);
291             }
292         }
293         RegCloseKey(handle);
294     }
295     return str;
296 }
297
298 /* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
299 static char*
300 get_regstr(const char *valuename, SV **svp)
301 {
302     char *str = get_regstr_from(HKEY_CURRENT_USER, valuename, svp);
303     if (!str)
304         str = get_regstr_from(HKEY_LOCAL_MACHINE, valuename, svp);
305     return str;
306 }
307
308 /* *prev_pathp (if non-NULL) is expected to be POK (valid allocated SvPVX(sv)) */
309 static char *
310 get_emd_part(SV **prev_pathp, STRLEN *const len, char *trailing_path, ...)
311 {
312     char base[10];
313     va_list ap;
314     char mod_name[MAX_PATH+1];
315     char *ptr;
316     char *optr;
317     char *strip;
318     STRLEN baselen;
319
320     va_start(ap, trailing_path);
321     strip = va_arg(ap, char *);
322
323     sprintf(base, "%d.%d", (int)PERL_REVISION, (int)PERL_VERSION);
324     baselen = strlen(base);
325
326     if (!*w32_module_name) {
327         set_w32_module_name();
328     }
329     strcpy(mod_name, w32_module_name);
330     ptr = strrchr(mod_name, '/');
331     while (ptr && strip) {
332         /* look for directories to skip back */
333         optr = ptr;
334         *ptr = '\0';
335         ptr = strrchr(mod_name, '/');
336         /* avoid stripping component if there is no slash,
337          * or it doesn't match ... */
338         if (!ptr || stricmp(ptr+1, strip) != 0) {
339             /* ... but not if component matches m|5\.$patchlevel.*| */
340             if (!ptr || !(*strip == '5' && *(ptr+1) == '5'
341                           && strncmp(strip, base, baselen) == 0
342                           && strncmp(ptr+1, base, baselen) == 0))
343             {
344                 *optr = '/';
345                 ptr = optr;
346             }
347         }
348         strip = va_arg(ap, char *);
349     }
350     if (!ptr) {
351         ptr = mod_name;
352         *ptr++ = '.';
353         *ptr = '/';
354     }
355     va_end(ap);
356     strcpy(++ptr, trailing_path);
357
358     /* only add directory if it exists */
359     if (GetFileAttributes(mod_name) != (DWORD) -1) {
360         /* directory exists */
361         dTHX;
362         if (!*prev_pathp)
363             *prev_pathp = sv_2mortal(newSVpvs(""));
364         else if (SvPVX(*prev_pathp))
365             sv_catpvs(*prev_pathp, ";");
366         sv_catpv(*prev_pathp, mod_name);
367         if(len)
368             *len = SvCUR(*prev_pathp);
369         return SvPVX(*prev_pathp);
370     }
371
372     return NULL;
373 }
374
375 EXTERN_C char *
376 win32_get_privlib(const char *pl, STRLEN *const len)
377 {
378     char *stdlib = "lib";
379     char buffer[MAX_PATH+1];
380     SV *sv = NULL;
381
382     /* $stdlib = $HKCU{"lib-$]"} || $HKLM{"lib-$]"} || $HKCU{"lib"} || $HKLM{"lib"} || "";  */
383     sprintf(buffer, "%s-%s", stdlib, pl);
384     if (!get_regstr(buffer, &sv))
385         (void)get_regstr(stdlib, &sv);
386
387     /* $stdlib .= ";$EMD/../../lib" */
388     return get_emd_part(&sv, len, stdlib, ARCHNAME, "bin", NULL);
389 }
390
391 static char *
392 win32_get_xlib(const char *pl, const char *xlib, const char *libname,
393                STRLEN *const len)
394 {
395     char regstr[40];
396     char pathstr[MAX_PATH+1];
397     SV *sv1 = NULL;
398     SV *sv2 = NULL;
399
400     /* $HKCU{"$xlib-$]"} || $HKLM{"$xlib-$]"} . ---; */
401     sprintf(regstr, "%s-%s", xlib, pl);
402     (void)get_regstr(regstr, &sv1);
403
404     /* $xlib .=
405      * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/$]/lib";  */
406     sprintf(pathstr, "%s/%s/lib", libname, pl);
407     (void)get_emd_part(&sv1, NULL, pathstr, ARCHNAME, "bin", pl, NULL);
408
409     /* $HKCU{$xlib} || $HKLM{$xlib} . ---; */
410     (void)get_regstr(xlib, &sv2);
411
412     /* $xlib .=
413      * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/lib";  */
414     sprintf(pathstr, "%s/lib", libname);
415     (void)get_emd_part(&sv2, NULL, pathstr, ARCHNAME, "bin", pl, NULL);
416
417     if (!sv1 && !sv2)
418         return NULL;
419     if (!sv1) {
420         sv1 = sv2;
421     } else if (sv2) {
422         dTHX;
423         sv_catpv(sv1, ";");
424         sv_catsv(sv1, sv2);
425     }
426
427     if (len)
428         *len = SvCUR(sv1);
429     return SvPVX(sv1);
430 }
431
432 EXTERN_C char *
433 win32_get_sitelib(const char *pl, STRLEN *const len)
434 {
435     return win32_get_xlib(pl, "sitelib", "site", len);
436 }
437
438 #ifndef PERL_VENDORLIB_NAME
439 #  define PERL_VENDORLIB_NAME   "vendor"
440 #endif
441
442 EXTERN_C char *
443 win32_get_vendorlib(const char *pl, STRLEN *const len)
444 {
445     return win32_get_xlib(pl, "vendorlib", PERL_VENDORLIB_NAME, len);
446 }
447
448 static BOOL
449 has_shell_metachars(const char *ptr)
450 {
451     int inquote = 0;
452     char quote = '\0';
453
454     /*
455      * Scan string looking for redirection (< or >) or pipe
456      * characters (|) that are not in a quoted string.
457      * Shell variable interpolation (%VAR%) can also happen inside strings.
458      */
459     while (*ptr) {
460         switch(*ptr) {
461         case '%':
462             return TRUE;
463         case '\'':
464         case '\"':
465             if (inquote) {
466                 if (quote == *ptr) {
467                     inquote = 0;
468                     quote = '\0';
469                 }
470             }
471             else {
472                 quote = *ptr;
473                 inquote++;
474             }
475             break;
476         case '>':
477         case '<':
478         case '|':
479             if (!inquote)
480                 return TRUE;
481         default:
482             break;
483         }
484         ++ptr;
485     }
486     return FALSE;
487 }
488
489 #if !defined(PERL_IMPLICIT_SYS)
490 /* since the current process environment is being updated in util.c
491  * the library functions will get the correct environment
492  */
493 PerlIO *
494 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
495 {
496     PERL_FLUSHALL_FOR_CHILD;
497     return win32_popen(cmd, mode);
498 }
499
500 long
501 Perl_my_pclose(pTHX_ PerlIO *fp)
502 {
503     return win32_pclose(fp);
504 }
505 #endif
506
507 DllExport unsigned long
508 win32_os_id(void)
509 {
510     return (unsigned long)g_osver.dwPlatformId;
511 }
512
513 DllExport int
514 win32_getpid(void)
515 {
516 #ifdef USE_ITHREADS
517     dTHX;
518     if (w32_pseudo_id)
519         return -((int)w32_pseudo_id);
520 #endif
521     return _getpid();
522 }
523
524 /* Tokenize a string.  Words are null-separated, and the list
525  * ends with a doubled null.  Any character (except null and
526  * including backslash) may be escaped by preceding it with a
527  * backslash (the backslash will be stripped).
528  * Returns number of words in result buffer.
529  */
530 static long
531 tokenize(const char *str, char **dest, char ***destv)
532 {
533     char *retstart = NULL;
534     char **retvstart = 0;
535     int items = -1;
536     if (str) {
537         int slen = strlen(str);
538         char *ret;
539         char **retv;
540         Newx(ret, slen+2, char);
541         Newx(retv, (slen+3)/2, char*);
542
543         retstart = ret;
544         retvstart = retv;
545         *retv = ret;
546         items = 0;
547         while (*str) {
548             *ret = *str++;
549             if (*ret == '\\' && *str)
550                 *ret = *str++;
551             else if (*ret == ' ') {
552                 while (*str == ' ')
553                     str++;
554                 if (ret == retstart)
555                     ret--;
556                 else {
557                     *ret = '\0';
558                     ++items;
559                     if (*str)
560                         *++retv = ret+1;
561                 }
562             }
563             else if (!*str)
564                 ++items;
565             ret++;
566         }
567         retvstart[items] = NULL;
568         *ret++ = '\0';
569         *ret = '\0';
570     }
571     *dest = retstart;
572     *destv = retvstart;
573     return items;
574 }
575
576 static void
577 get_shell(void)
578 {
579     dTHX;
580     if (!w32_perlshell_tokens) {
581         /* we don't use COMSPEC here for two reasons:
582          *  1. the same reason perl on UNIX doesn't use SHELL--rampant and
583          *     uncontrolled unportability of the ensuing scripts.
584          *  2. PERL5SHELL could be set to a shell that may not be fit for
585          *     interactive use (which is what most programs look in COMSPEC
586          *     for).
587          */
588         const char* defaultshell = "cmd.exe /x/d/c";
589         const char *usershell = PerlEnv_getenv("PERL5SHELL");
590         w32_perlshell_items = tokenize(usershell ? usershell : defaultshell,
591                                        &w32_perlshell_tokens,
592                                        &w32_perlshell_vec);
593     }
594 }
595
596 int
597 Perl_do_aspawn(pTHX_ SV *really, SV **mark, SV **sp)
598 {
599     char **argv;
600     char *str;
601     int status;
602     int flag = P_WAIT;
603     int index = 0;
604
605     PERL_ARGS_ASSERT_DO_ASPAWN;
606
607     if (sp <= mark)
608         return -1;
609
610     get_shell();
611     Newx(argv, (sp - mark) + w32_perlshell_items + 2, char*);
612
613     if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
614         ++mark;
615         flag = SvIVx(*mark);
616     }
617
618     while (++mark <= sp) {
619         if (*mark && (str = SvPV_nolen(*mark)))
620             argv[index++] = str;
621         else
622             argv[index++] = "";
623     }
624     argv[index++] = 0;
625
626     status = win32_spawnvp(flag,
627                            (const char*)(really ? SvPV_nolen(really) : argv[0]),
628                            (const char* const*)argv);
629
630     if (status < 0 && (errno == ENOEXEC || errno == ENOENT)) {
631         /* possible shell-builtin, invoke with shell */
632         int sh_items;
633         sh_items = w32_perlshell_items;
634         while (--index >= 0)
635             argv[index+sh_items] = argv[index];
636         while (--sh_items >= 0)
637             argv[sh_items] = w32_perlshell_vec[sh_items];
638
639         status = win32_spawnvp(flag,
640                                (const char*)(really ? SvPV_nolen(really) : argv[0]),
641                                (const char* const*)argv);
642     }
643
644     if (flag == P_NOWAIT) {
645         PL_statusvalue = -1;    /* >16bits hint for pp_system() */
646     }
647     else {
648         if (status < 0) {
649             if (ckWARN(WARN_EXEC))
650                 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't spawn \"%s\": %s", argv[0], strerror(errno));
651             status = 255 * 256;
652         }
653         else
654             status *= 256;
655         PL_statusvalue = status;
656     }
657     Safefree(argv);
658     return (status);
659 }
660
661 /* returns pointer to the next unquoted space or the end of the string */
662 static char*
663 find_next_space(const char *s)
664 {
665     bool in_quotes = FALSE;
666     while (*s) {
667         /* ignore doubled backslashes, or backslash+quote */
668         if (*s == '\\' && (s[1] == '\\' || s[1] == '"')) {
669             s += 2;
670         }
671         /* keep track of when we're within quotes */
672         else if (*s == '"') {
673             s++;
674             in_quotes = !in_quotes;
675         }
676         /* break it up only at spaces that aren't in quotes */
677         else if (!in_quotes && isSPACE(*s))
678             return (char*)s;
679         else
680             s++;
681     }
682     return (char*)s;
683 }
684
685 static int
686 do_spawn2(pTHX_ const char *cmd, int exectype) {
687     return do_spawn2_handles(aTHX_ cmd, exectype, NULL);
688 }
689
690 static int
691 do_spawn2_handles(pTHX_ const char *cmd, int exectype, const int *handles)
692 {
693     char **a;
694     char *s;
695     char **argv;
696     int status = -1;
697     BOOL needToTry = TRUE;
698     char *cmd2;
699
700     /* Save an extra exec if possible. See if there are shell
701      * metacharacters in it */
702     if (!has_shell_metachars(cmd)) {
703         Newx(argv, strlen(cmd) / 2 + 2, char*);
704         Newx(cmd2, strlen(cmd) + 1, char);
705         strcpy(cmd2, cmd);
706         a = argv;
707         for (s = cmd2; *s;) {
708             while (*s && isSPACE(*s))
709                 s++;
710             if (*s)
711                 *(a++) = s;
712             s = find_next_space(s);
713             if (*s)
714                 *s++ = '\0';
715         }
716         *a = NULL;
717         if (argv[0]) {
718             switch (exectype) {
719             case EXECF_SPAWN:
720                 status = win32_spawnvp(P_WAIT, argv[0],
721                                        (const char* const*)argv);
722                 break;
723             case EXECF_SPAWN_NOWAIT:
724                 status = do_spawnvp_handles(P_NOWAIT, argv[0],
725                                             (const char* const*)argv, handles);
726                 break;
727             case EXECF_EXEC:
728                 status = win32_execvp(argv[0], (const char* const*)argv);
729                 break;
730             }
731             if (status != -1 || errno == 0)
732                 needToTry = FALSE;
733         }
734         Safefree(argv);
735         Safefree(cmd2);
736     }
737     if (needToTry) {
738         char **argv;
739         int i = -1;
740         get_shell();
741         Newx(argv, w32_perlshell_items + 2, char*);
742         while (++i < w32_perlshell_items)
743             argv[i] = w32_perlshell_vec[i];
744         argv[i++] = (char *)cmd;
745         argv[i] = NULL;
746         switch (exectype) {
747         case EXECF_SPAWN:
748             status = win32_spawnvp(P_WAIT, argv[0],
749                                    (const char* const*)argv);
750             break;
751         case EXECF_SPAWN_NOWAIT:
752             status = do_spawnvp_handles(P_NOWAIT, argv[0],
753                                         (const char* const*)argv, handles);
754             break;
755         case EXECF_EXEC:
756             status = win32_execvp(argv[0], (const char* const*)argv);
757             break;
758         }
759         cmd = argv[0];
760         Safefree(argv);
761     }
762     if (exectype == EXECF_SPAWN_NOWAIT) {
763         PL_statusvalue = -1;    /* >16bits hint for pp_system() */
764     }
765     else {
766         if (status < 0) {
767             if (ckWARN(WARN_EXEC))
768                 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s",
769                      (exectype == EXECF_EXEC ? "exec" : "spawn"),
770                      cmd, strerror(errno));
771             status = 255 * 256;
772         }
773         else
774             status *= 256;
775         PL_statusvalue = status;
776     }
777     return (status);
778 }
779
780 int
781 Perl_do_spawn(pTHX_ char *cmd)
782 {
783     PERL_ARGS_ASSERT_DO_SPAWN;
784
785     return do_spawn2(aTHX_ cmd, EXECF_SPAWN);
786 }
787
788 int
789 Perl_do_spawn_nowait(pTHX_ char *cmd)
790 {
791     PERL_ARGS_ASSERT_DO_SPAWN_NOWAIT;
792
793     return do_spawn2(aTHX_ cmd, EXECF_SPAWN_NOWAIT);
794 }
795
796 bool
797 Perl_do_exec(pTHX_ const char *cmd)
798 {
799     PERL_ARGS_ASSERT_DO_EXEC;
800
801     do_spawn2(aTHX_ cmd, EXECF_EXEC);
802     return FALSE;
803 }
804
805 /* The idea here is to read all the directory names into a string table
806  * (separated by nulls) and when one of the other dir functions is called
807  * return the pointer to the current file name.
808  */
809 DllExport DIR *
810 win32_opendir(const char *filename)
811 {
812     dTHXa(NULL);
813     DIR                 *dirp;
814     long                len;
815     long                idx;
816     char                scanname[MAX_PATH+3];
817     WCHAR               wscanname[sizeof(scanname)];
818     WIN32_FIND_DATAW    wFindData;
819     char                buffer[MAX_PATH*2];
820     BOOL                use_default;
821
822     len = strlen(filename);
823     if (len == 0) {
824         errno = ENOENT;
825         return NULL;
826     }
827     if (len > MAX_PATH) {
828         errno = ENAMETOOLONG;
829         return NULL;
830     }
831
832     /* Get us a DIR structure */
833     Newxz(dirp, 1, DIR);
834
835     /* Create the search pattern */
836     strcpy(scanname, filename);
837
838     /* bare drive name means look in cwd for drive */
839     if (len == 2 && isALPHA(scanname[0]) && scanname[1] == ':') {
840         scanname[len++] = '.';
841         scanname[len++] = '/';
842     }
843     else if (scanname[len-1] != '/' && scanname[len-1] != '\\') {
844         scanname[len++] = '/';
845     }
846     scanname[len++] = '*';
847     scanname[len] = '\0';
848
849     /* do the FindFirstFile call */
850     MultiByteToWideChar(CP_ACP, 0, scanname, -1, wscanname, sizeof(wscanname)/sizeof(WCHAR));
851     aTHXa(PERL_GET_THX);
852     dirp->handle = FindFirstFileW(PerlDir_mapW(wscanname), &wFindData);
853
854     if (dirp->handle == INVALID_HANDLE_VALUE) {
855         DWORD err = GetLastError();
856         /* FindFirstFile() fails on empty drives! */
857         switch (err) {
858         case ERROR_FILE_NOT_FOUND:
859             return dirp;
860         case ERROR_NO_MORE_FILES:
861         case ERROR_PATH_NOT_FOUND:
862             errno = ENOENT;
863             break;
864         case ERROR_NOT_ENOUGH_MEMORY:
865             errno = ENOMEM;
866             break;
867         default:
868             errno = EINVAL;
869             break;
870         }
871         Safefree(dirp);
872         return NULL;
873     }
874
875     use_default = FALSE;
876     WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
877                         wFindData.cFileName, -1,
878                         buffer, sizeof(buffer), NULL, &use_default);
879     if (use_default && *wFindData.cAlternateFileName) {
880         WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
881                             wFindData.cAlternateFileName, -1,
882                             buffer, sizeof(buffer), NULL, NULL);
883     }
884
885     /* now allocate the first part of the string table for
886      * the filenames that we find.
887      */
888     idx = strlen(buffer)+1;
889     if (idx < 256)
890         dirp->size = 256;
891     else
892         dirp->size = idx;
893     Newx(dirp->start, dirp->size, char);
894     strcpy(dirp->start, buffer);
895     dirp->nfiles++;
896     dirp->end = dirp->curr = dirp->start;
897     dirp->end += idx;
898     return dirp;
899 }
900
901
902 /* Readdir just returns the current string pointer and bumps the
903  * string pointer to the nDllExport entry.
904  */
905 DllExport struct direct *
906 win32_readdir(DIR *dirp)
907 {
908     long         len;
909
910     if (dirp->curr) {
911         /* first set up the structure to return */
912         len = strlen(dirp->curr);
913         strcpy(dirp->dirstr.d_name, dirp->curr);
914         dirp->dirstr.d_namlen = len;
915
916         /* Fake an inode */
917         dirp->dirstr.d_ino = dirp->curr - dirp->start;
918
919         /* Now set up for the next call to readdir */
920         dirp->curr += len + 1;
921         if (dirp->curr >= dirp->end) {
922             BOOL res;
923             char buffer[MAX_PATH*2];
924
925             if (dirp->handle == INVALID_HANDLE_VALUE) {
926                 res = 0;
927             }
928             /* finding the next file that matches the wildcard
929              * (which should be all of them in this directory!).
930              */
931             else {
932                 WIN32_FIND_DATAW wFindData;
933                 res = FindNextFileW(dirp->handle, &wFindData);
934                 if (res) {
935                     BOOL use_default = FALSE;
936                     WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
937                                         wFindData.cFileName, -1,
938                                         buffer, sizeof(buffer), NULL, &use_default);
939                     if (use_default && *wFindData.cAlternateFileName) {
940                         WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
941                                             wFindData.cAlternateFileName, -1,
942                                             buffer, sizeof(buffer), NULL, NULL);
943                     }
944                 }
945             }
946             if (res) {
947                 long endpos = dirp->end - dirp->start;
948                 long newsize = endpos + strlen(buffer) + 1;
949                 /* bump the string table size by enough for the
950                  * new name and its null terminator */
951                 while (newsize > dirp->size) {
952                     long curpos = dirp->curr - dirp->start;
953                     dirp->size *= 2;
954                     Renew(dirp->start, dirp->size, char);
955                     dirp->curr = dirp->start + curpos;
956                 }
957                 strcpy(dirp->start + endpos, buffer);
958                 dirp->end = dirp->start + newsize;
959                 dirp->nfiles++;
960             }
961             else {
962                 dirp->curr = NULL;
963                 if (dirp->handle != INVALID_HANDLE_VALUE) {
964                     FindClose(dirp->handle);
965                     dirp->handle = INVALID_HANDLE_VALUE;
966                 }
967             }
968         }
969         return &(dirp->dirstr);
970     }
971     else
972         return NULL;
973 }
974
975 /* Telldir returns the current string pointer position */
976 DllExport long
977 win32_telldir(DIR *dirp)
978 {
979     return dirp->curr ? (dirp->curr - dirp->start) : -1;
980 }
981
982
983 /* Seekdir moves the string pointer to a previously saved position
984  * (returned by telldir).
985  */
986 DllExport void
987 win32_seekdir(DIR *dirp, long loc)
988 {
989     dirp->curr = loc == -1 ? NULL : dirp->start + loc;
990 }
991
992 /* Rewinddir resets the string pointer to the start */
993 DllExport void
994 win32_rewinddir(DIR *dirp)
995 {
996     dirp->curr = dirp->start;
997 }
998
999 /* free the memory allocated by opendir */
1000 DllExport int
1001 win32_closedir(DIR *dirp)
1002 {
1003     if (dirp->handle != INVALID_HANDLE_VALUE)
1004         FindClose(dirp->handle);
1005     Safefree(dirp->start);
1006     Safefree(dirp);
1007     return 1;
1008 }
1009
1010 /* duplicate a open DIR* for interpreter cloning */
1011 DllExport DIR *
1012 win32_dirp_dup(DIR *const dirp, CLONE_PARAMS *const param)
1013 {
1014     dVAR;
1015     PerlInterpreter *const from = param->proto_perl;
1016     PerlInterpreter *const to   = (PerlInterpreter *)PERL_GET_THX;
1017
1018     long pos;
1019     DIR *dup;
1020
1021     /* switch back to original interpreter because win32_readdir()
1022      * might Renew(dirp->start).
1023      */
1024     if (from != to) {
1025         PERL_SET_THX(from);
1026     }
1027
1028     /* mark current position; read all remaining entries into the
1029      * cache, and then restore to current position.
1030      */
1031     pos = win32_telldir(dirp);
1032     while (win32_readdir(dirp)) {
1033         /* read all entries into cache */
1034     }
1035     win32_seekdir(dirp, pos);
1036
1037     /* switch back to new interpreter to allocate new DIR structure */
1038     if (from != to) {
1039         PERL_SET_THX(to);
1040     }
1041
1042     Newx(dup, 1, DIR);
1043     memcpy(dup, dirp, sizeof(DIR));
1044
1045     Newx(dup->start, dirp->size, char);
1046     memcpy(dup->start, dirp->start, dirp->size);
1047
1048     dup->end = dup->start + (dirp->end - dirp->start);
1049     if (dirp->curr)
1050         dup->curr = dup->start + (dirp->curr - dirp->start);
1051
1052     return dup;
1053 }
1054
1055 /*
1056  * various stubs
1057  */
1058
1059
1060 /* Ownership
1061  *
1062  * Just pretend that everyone is a superuser. NT will let us know if
1063  * we don\'t really have permission to do something.
1064  */
1065
1066 #define ROOT_UID    ((uid_t)0)
1067 #define ROOT_GID    ((gid_t)0)
1068
1069 uid_t
1070 getuid(void)
1071 {
1072     return ROOT_UID;
1073 }
1074
1075 uid_t
1076 geteuid(void)
1077 {
1078     return ROOT_UID;
1079 }
1080
1081 gid_t
1082 getgid(void)
1083 {
1084     return ROOT_GID;
1085 }
1086
1087 gid_t
1088 getegid(void)
1089 {
1090     return ROOT_GID;
1091 }
1092
1093 int
1094 setuid(uid_t auid)
1095 {
1096     return (auid == ROOT_UID ? 0 : -1);
1097 }
1098
1099 int
1100 setgid(gid_t agid)
1101 {
1102     return (agid == ROOT_GID ? 0 : -1);
1103 }
1104
1105 EXTERN_C char *
1106 getlogin(void)
1107 {
1108     dTHX;
1109     char *buf = w32_getlogin_buffer;
1110     DWORD size = sizeof(w32_getlogin_buffer);
1111     if (GetUserName(buf,&size))
1112         return buf;
1113     return (char*)NULL;
1114 }
1115
1116 int
1117 chown(const char *path, uid_t owner, gid_t group)
1118 {
1119     /* XXX noop */
1120     return 0;
1121 }
1122
1123 /*
1124  * XXX this needs strengthening  (for PerlIO)
1125  *   -- BKS, 11-11-200
1126 */
1127 #if !defined(__MINGW64_VERSION_MAJOR) || __MINGW64_VERSION_MAJOR < 4
1128 int mkstemp(const char *path)
1129 {
1130     dTHX;
1131     char buf[MAX_PATH+1];
1132     int i = 0, fd = -1;
1133
1134 retry:
1135     if (i++ > 10) { /* give up */
1136         errno = ENOENT;
1137         return -1;
1138     }
1139     if (!GetTempFileNameA((LPCSTR)path, "plr", 1, buf)) {
1140         errno = ENOENT;
1141         return -1;
1142     }
1143     fd = PerlLIO_open3(buf, O_CREAT|O_RDWR|O_EXCL, 0600);
1144     if (fd == -1)
1145         goto retry;
1146     return fd;
1147 }
1148 #endif
1149
1150 static long
1151 find_pid(pTHX_ int pid)
1152 {
1153     long child = w32_num_children;
1154     while (--child >= 0) {
1155         if ((int)w32_child_pids[child] == pid)
1156             return child;
1157     }
1158     return -1;
1159 }
1160
1161 static void
1162 remove_dead_process(long child)
1163 {
1164     if (child >= 0) {
1165         dTHX;
1166         CloseHandle(w32_child_handles[child]);
1167         Move(&w32_child_handles[child+1], &w32_child_handles[child],
1168              (w32_num_children-child-1), HANDLE);
1169         Move(&w32_child_pids[child+1], &w32_child_pids[child],
1170              (w32_num_children-child-1), DWORD);
1171         w32_num_children--;
1172     }
1173 }
1174
1175 #ifdef USE_ITHREADS
1176 static long
1177 find_pseudo_pid(pTHX_ int pid)
1178 {
1179     long child = w32_num_pseudo_children;
1180     while (--child >= 0) {
1181         if ((int)w32_pseudo_child_pids[child] == pid)
1182             return child;
1183     }
1184     return -1;
1185 }
1186
1187 static void
1188 remove_dead_pseudo_process(long child)
1189 {
1190     if (child >= 0) {
1191         dTHX;
1192         CloseHandle(w32_pseudo_child_handles[child]);
1193         Move(&w32_pseudo_child_handles[child+1], &w32_pseudo_child_handles[child],
1194              (w32_num_pseudo_children-child-1), HANDLE);
1195         Move(&w32_pseudo_child_pids[child+1], &w32_pseudo_child_pids[child],
1196              (w32_num_pseudo_children-child-1), DWORD);
1197         Move(&w32_pseudo_child_message_hwnds[child+1], &w32_pseudo_child_message_hwnds[child],
1198              (w32_num_pseudo_children-child-1), HWND);
1199         Move(&w32_pseudo_child_sigterm[child+1], &w32_pseudo_child_sigterm[child],
1200              (w32_num_pseudo_children-child-1), char);
1201         w32_num_pseudo_children--;
1202     }
1203 }
1204
1205 void
1206 win32_wait_for_children(pTHX)
1207 {
1208     if (w32_pseudo_children && w32_num_pseudo_children) {
1209         long child = 0;
1210         long count = 0;
1211         HANDLE handles[MAXIMUM_WAIT_OBJECTS];
1212
1213         for (child = 0; child < w32_num_pseudo_children; ++child) {
1214             if (!w32_pseudo_child_sigterm[child])
1215                 handles[count++] = w32_pseudo_child_handles[child];
1216         }
1217         /* XXX should use MsgWaitForMultipleObjects() to continue
1218          * XXX processing messages while we wait.
1219          */
1220         WaitForMultipleObjects(count, handles, TRUE, INFINITE);
1221
1222         while (w32_num_pseudo_children)
1223             CloseHandle(w32_pseudo_child_handles[--w32_num_pseudo_children]);
1224     }
1225 }
1226 #endif
1227
1228 static int
1229 terminate_process(DWORD pid, HANDLE process_handle, int sig)
1230 {
1231     switch(sig) {
1232     case 0:
1233         /* "Does process exist?" use of kill */
1234         return 1;
1235     case 2:
1236         if (GenerateConsoleCtrlEvent(CTRL_C_EVENT, pid))
1237             return 1;
1238         break;
1239     case SIGBREAK:
1240     case SIGTERM:
1241         if (GenerateConsoleCtrlEvent(CTRL_BREAK_EVENT, pid))
1242             return 1;
1243         break;
1244     default: /* For now be backwards compatible with perl 5.6 */
1245     case 9:
1246         /* Note that we will only be able to kill processes owned by the
1247          * current process owner, even when we are running as an administrator.
1248          * To kill processes of other owners we would need to set the
1249          * 'SeDebugPrivilege' privilege before obtaining the process handle.
1250          */
1251         if (TerminateProcess(process_handle, sig))
1252             return 1;
1253         break;
1254     }
1255     return 0;
1256 }
1257
1258 /* returns number of processes killed */
1259 static int
1260 my_killpg(int pid, int sig)
1261 {
1262     HANDLE process_handle;
1263     HANDLE snapshot_handle;
1264     int killed = 0;
1265
1266     process_handle = OpenProcess(PROCESS_TERMINATE, FALSE, pid);
1267     if (process_handle == NULL)
1268         return 0;
1269
1270     killed += terminate_process(pid, process_handle, sig);
1271
1272     snapshot_handle = CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
1273     if (snapshot_handle != INVALID_HANDLE_VALUE) {
1274         PROCESSENTRY32 entry;
1275
1276         entry.dwSize = sizeof(entry);
1277         if (Process32First(snapshot_handle, &entry)) {
1278             do {
1279                 if (entry.th32ParentProcessID == (DWORD)pid)
1280                     killed += my_killpg(entry.th32ProcessID, sig);
1281                 entry.dwSize = sizeof(entry);
1282             }
1283             while (Process32Next(snapshot_handle, &entry));
1284         }
1285         CloseHandle(snapshot_handle);
1286     }
1287     CloseHandle(process_handle);
1288     return killed;
1289 }
1290
1291 /* returns number of processes killed */
1292 static int
1293 my_kill(int pid, int sig)
1294 {
1295     int retval = 0;
1296     HANDLE process_handle;
1297
1298     if (sig < 0)
1299         return my_killpg(pid, -sig);
1300
1301     process_handle = OpenProcess(PROCESS_TERMINATE, FALSE, pid);
1302     /* OpenProcess() returns NULL on error, *not* INVALID_HANDLE_VALUE */
1303     if (process_handle != NULL) {
1304         retval = terminate_process(pid, process_handle, sig);
1305         CloseHandle(process_handle);
1306     }
1307     return retval;
1308 }
1309
1310 #ifdef USE_ITHREADS
1311 /* Get a child pseudo-process HWND, with retrying and delaying/yielding.
1312  * The "tries" parameter is the number of retries to make, with a Sleep(1)
1313  * (waiting and yielding the time slot) between each try. Specifying 0 causes
1314  * only Sleep(0) (no waiting and potentially no yielding) to be used, so is not
1315  * recommended
1316  * Returns an hwnd != INVALID_HANDLE_VALUE (so be aware that NULL can be
1317  * returned) or croaks if the child pseudo-process doesn't schedule and deliver
1318  * a HWND in the time period allowed.
1319  */
1320 static HWND
1321 get_hwnd_delay(pTHX, long child, DWORD tries)
1322 {
1323     HWND hwnd = w32_pseudo_child_message_hwnds[child];
1324     if (hwnd != INVALID_HANDLE_VALUE) return hwnd;
1325
1326     /* Pseudo-process has not yet properly initialized since hwnd isn't set.
1327      * Fast sleep: On some NT kernels/systems, a Sleep(0) won't deschedule a
1328      * thread 100% of the time since threads are attached to a CPU for NUMA and
1329      * caching reasons, and the child thread was attached to a different CPU
1330      * therefore there is no workload on that CPU and Sleep(0) returns control
1331      * without yielding the time slot.
1332      * https://rt.perl.org/rt3/Ticket/Display.html?id=88840
1333      */
1334     Sleep(0);
1335     win32_async_check(aTHX);
1336     hwnd = w32_pseudo_child_message_hwnds[child];
1337     if (hwnd != INVALID_HANDLE_VALUE) return hwnd;
1338
1339     {
1340         unsigned int count = 0;
1341         /* No Sleep(1) if tries==0, just fail instead if we get this far. */
1342         while (count++ < tries) {
1343             Sleep(1);
1344             win32_async_check(aTHX);
1345             hwnd = w32_pseudo_child_message_hwnds[child];
1346             if (hwnd != INVALID_HANDLE_VALUE) return hwnd;
1347         }
1348     }
1349
1350     Perl_croak(aTHX_ "panic: child pseudo-process was never scheduled");
1351 }
1352 #endif
1353
1354 DllExport int
1355 win32_kill(int pid, int sig)
1356 {
1357     dTHX;
1358     long child;
1359 #ifdef USE_ITHREADS
1360     if (pid < 0) {
1361         /* it is a pseudo-forked child */
1362         child = find_pseudo_pid(aTHX_ -pid);
1363         if (child >= 0) {
1364             HANDLE hProcess = w32_pseudo_child_handles[child];
1365             switch (sig) {
1366                 case 0:
1367                     /* "Does process exist?" use of kill */
1368                     return 0;
1369
1370                 case 9: {
1371                     /* kill -9 style un-graceful exit */
1372                     /* Do a wait to make sure child starts and isn't in DLL
1373                      * Loader Lock */
1374                     HWND hwnd = get_hwnd_delay(aTHX, child, 5);
1375                     if (TerminateThread(hProcess, sig)) {
1376                         /* Allow the scheduler to finish cleaning up the other
1377                          * thread.
1378                          * Otherwise, if we ExitProcess() before another context
1379                          * switch happens we will end up with a process exit
1380                          * code of "sig" instead of our own exit status.
1381                          * https://rt.cpan.org/Ticket/Display.html?id=66016#txn-908976
1382                          */
1383                         Sleep(0);
1384                         remove_dead_pseudo_process(child);
1385                         return 0;
1386                     }
1387                     break;
1388                 }
1389
1390                 default: {
1391                     HWND hwnd = get_hwnd_delay(aTHX, child, 5);
1392                     /* We fake signals to pseudo-processes using Win32
1393                      * message queue. */
1394                     if ((hwnd != NULL && PostMessage(hwnd, WM_USER_KILL, sig, 0)) ||
1395                         PostThreadMessage(-pid, WM_USER_KILL, sig, 0))
1396                     {
1397                         /* Don't wait for child process to terminate after we send a
1398                          * SIGTERM because the child may be blocked in a system call
1399                          * and never receive the signal.
1400                          */
1401                         if (sig == SIGTERM) {
1402                             Sleep(0);
1403                             w32_pseudo_child_sigterm[child] = 1;
1404                         }
1405                         /* It might be us ... */
1406                         PERL_ASYNC_CHECK();
1407                         return 0;
1408                     }
1409                     break;
1410                 }
1411             } /* switch */
1412         }
1413     }
1414     else
1415 #endif
1416     {
1417         child = find_pid(aTHX_ pid);
1418         if (child >= 0) {
1419             if (my_kill(pid, sig)) {
1420                 DWORD exitcode = 0;
1421                 if (GetExitCodeProcess(w32_child_handles[child], &exitcode) &&
1422                     exitcode != STILL_ACTIVE)
1423                 {
1424                     remove_dead_process(child);
1425                 }
1426                 return 0;
1427             }
1428         }
1429         else {
1430             if (my_kill(pid, sig))
1431                 return 0;
1432         }
1433     }
1434     errno = EINVAL;
1435     return -1;
1436 }
1437
1438 DllExport int
1439 win32_stat(const char *path, Stat_t *sbuf)
1440 {
1441     char        buffer[MAX_PATH+1];
1442     int         l = strlen(path);
1443     dTHX;
1444     int         res;
1445     int         nlink = 1;
1446     BOOL        expect_dir = FALSE;
1447
1448     GV          *gv_sloppy = gv_fetchpvs("\027IN32_SLOPPY_STAT",
1449                                          GV_NOTQUAL, SVt_PV);
1450     BOOL        sloppy = gv_sloppy && SvTRUE(GvSV(gv_sloppy));
1451
1452     if (l > 1) {
1453         switch(path[l - 1]) {
1454         /* FindFirstFile() and stat() are buggy with a trailing
1455          * slashes, except for the root directory of a drive */
1456         case '\\':
1457         case '/':
1458             if (l > sizeof(buffer)) {
1459                 errno = ENAMETOOLONG;
1460                 return -1;
1461             }
1462             --l;
1463             strncpy(buffer, path, l);
1464             /* remove additional trailing slashes */
1465             while (l > 1 && (buffer[l-1] == '/' || buffer[l-1] == '\\'))
1466                 --l;
1467             /* add back slash if we otherwise end up with just a drive letter */
1468             if (l == 2 && isALPHA(buffer[0]) && buffer[1] == ':')
1469                 buffer[l++] = '\\';
1470             buffer[l] = '\0';
1471             path = buffer;
1472             expect_dir = TRUE;
1473             break;
1474
1475         /* FindFirstFile() is buggy with "x:", so add a dot :-( */
1476         case ':':
1477             if (l == 2 && isALPHA(path[0])) {
1478                 buffer[0] = path[0];
1479                 buffer[1] = ':';
1480                 buffer[2] = '.';
1481                 buffer[3] = '\0';
1482                 l = 3;
1483                 path = buffer;
1484             }
1485             break;
1486         }
1487     }
1488
1489     path = PerlDir_mapA(path);
1490     l = strlen(path);
1491
1492     if (!sloppy) {
1493         /* We must open & close the file once; otherwise file attribute changes  */
1494         /* might not yet have propagated to "other" hard links of the same file. */
1495         /* This also gives us an opportunity to determine the number of links.   */
1496         HANDLE handle = CreateFileA(path, 0, 0, NULL, OPEN_EXISTING, 0, NULL);
1497         if (handle != INVALID_HANDLE_VALUE) {
1498             BY_HANDLE_FILE_INFORMATION bhi;
1499             if (GetFileInformationByHandle(handle, &bhi))
1500                 nlink = bhi.nNumberOfLinks;
1501             CloseHandle(handle);
1502         }
1503     }
1504
1505     /* path will be mapped correctly above */
1506 #if defined(WIN64) || defined(USE_LARGE_FILES)
1507     res = _stati64(path, sbuf);
1508 #else
1509     res = stat(path, sbuf);
1510 #endif
1511     sbuf->st_nlink = nlink;
1512
1513     if (res < 0) {
1514         /* CRT is buggy on sharenames, so make sure it really isn't.
1515          * XXX using GetFileAttributesEx() will enable us to set
1516          * sbuf->st_*time (but note that's not available on the
1517          * Windows of 1995) */
1518         DWORD r = GetFileAttributesA(path);
1519         if (r != 0xffffffff && (r & FILE_ATTRIBUTE_DIRECTORY)) {
1520             /* sbuf may still contain old garbage since stat() failed */
1521             Zero(sbuf, 1, Stat_t);
1522             sbuf->st_mode = S_IFDIR | S_IREAD;
1523             errno = 0;
1524             if (!(r & FILE_ATTRIBUTE_READONLY))
1525                 sbuf->st_mode |= S_IWRITE | S_IEXEC;
1526             return 0;
1527         }
1528     }
1529     else {
1530         if (l == 3 && isALPHA(path[0]) && path[1] == ':'
1531             && (path[2] == '\\' || path[2] == '/'))
1532         {
1533             /* The drive can be inaccessible, some _stat()s are buggy */
1534             if (!GetVolumeInformationA(path,NULL,0,NULL,NULL,NULL,NULL,0)) {
1535                 errno = ENOENT;
1536                 return -1;
1537             }
1538         }
1539         if (expect_dir && !S_ISDIR(sbuf->st_mode)) {
1540             errno = ENOTDIR;
1541             return -1;
1542         }
1543         if (S_ISDIR(sbuf->st_mode)) {
1544             /* Ensure the "write" bit is switched off in the mode for
1545              * directories with the read-only attribute set. Some compilers
1546              * switch it on for directories, which is technically correct
1547              * (directories are indeed always writable unless denied by DACLs),
1548              * but we want stat() and -w to reflect the state of the read-only
1549              * attribute for symmetry with chmod(). */
1550             DWORD r = GetFileAttributesA(path);
1551             if (r != 0xffffffff && (r & FILE_ATTRIBUTE_READONLY)) {
1552                 sbuf->st_mode &= ~S_IWRITE;
1553             }
1554         }
1555     }
1556     return res;
1557 }
1558
1559 #define isSLASH(c) ((c) == '/' || (c) == '\\')
1560 #define SKIP_SLASHES(s) \
1561     STMT_START {                                \
1562         while (*(s) && isSLASH(*(s)))           \
1563             ++(s);                              \
1564     } STMT_END
1565 #define COPY_NONSLASHES(d,s) \
1566     STMT_START {                                \
1567         while (*(s) && !isSLASH(*(s)))          \
1568             *(d)++ = *(s)++;                    \
1569     } STMT_END
1570
1571 /* Find the longname of a given path.  path is destructively modified.
1572  * It should have space for at least MAX_PATH characters. */
1573 DllExport char *
1574 win32_longpath(char *path)
1575 {
1576     WIN32_FIND_DATA fdata;
1577     HANDLE fhand;
1578     char tmpbuf[MAX_PATH+1];
1579     char *tmpstart = tmpbuf;
1580     char *start = path;
1581     char sep;
1582     if (!path)
1583         return NULL;
1584
1585     /* drive prefix */
1586     if (isALPHA(path[0]) && path[1] == ':') {
1587         start = path + 2;
1588         *tmpstart++ = path[0];
1589         *tmpstart++ = ':';
1590     }
1591     /* UNC prefix */
1592     else if (isSLASH(path[0]) && isSLASH(path[1])) {
1593         start = path + 2;
1594         *tmpstart++ = path[0];
1595         *tmpstart++ = path[1];
1596         SKIP_SLASHES(start);
1597         COPY_NONSLASHES(tmpstart,start);        /* copy machine name */
1598         if (*start) {
1599             *tmpstart++ = *start++;
1600             SKIP_SLASHES(start);
1601             COPY_NONSLASHES(tmpstart,start);    /* copy share name */
1602         }
1603     }
1604     *tmpstart = '\0';
1605     while (*start) {
1606         /* copy initial slash, if any */
1607         if (isSLASH(*start)) {
1608             *tmpstart++ = *start++;
1609             *tmpstart = '\0';
1610             SKIP_SLASHES(start);
1611         }
1612
1613         /* FindFirstFile() expands "." and "..", so we need to pass
1614          * those through unmolested */
1615         if (*start == '.'
1616             && (!start[1] || isSLASH(start[1])
1617                 || (start[1] == '.' && (!start[2] || isSLASH(start[2])))))
1618         {
1619             COPY_NONSLASHES(tmpstart,start);    /* copy "." or ".." */
1620             *tmpstart = '\0';
1621             continue;
1622         }
1623
1624         /* if this is the end, bust outta here */
1625         if (!*start)
1626             break;
1627
1628         /* now we're at a non-slash; walk up to next slash */
1629         while (*start && !isSLASH(*start))
1630             ++start;
1631
1632         /* stop and find full name of component */
1633         sep = *start;
1634         *start = '\0';
1635         fhand = FindFirstFile(path,&fdata);
1636         *start = sep;
1637         if (fhand != INVALID_HANDLE_VALUE) {
1638             STRLEN len = strlen(fdata.cFileName);
1639             if ((STRLEN)(tmpbuf + sizeof(tmpbuf) - tmpstart) > len) {
1640                 strcpy(tmpstart, fdata.cFileName);
1641                 tmpstart += len;
1642                 FindClose(fhand);
1643             }
1644             else {
1645                 FindClose(fhand);
1646                 errno = ERANGE;
1647                 return NULL;
1648             }
1649         }
1650         else {
1651             /* failed a step, just return without side effects */
1652             /*PerlIO_printf(Perl_debug_log, "Failed to find %s\n", path);*/
1653             errno = EINVAL;
1654             return NULL;
1655         }
1656     }
1657     strcpy(path,tmpbuf);
1658     return path;
1659 }
1660
1661 static void
1662 out_of_memory(void)
1663 {
1664     if (PL_curinterp)
1665         croak_no_mem();
1666     exit(1);
1667 }
1668
1669 void
1670 win32_croak_not_implemented(const char * fname)
1671 {
1672     PERL_ARGS_ASSERT_WIN32_CROAK_NOT_IMPLEMENTED;
1673
1674     Perl_croak_nocontext("%s not implemented!\n", fname);
1675 }
1676
1677 /* Converts a wide character (UTF-16) string to the Windows ANSI code page,
1678  * potentially using the system's default replacement character for any
1679  * unrepresentable characters. The caller must free() the returned string. */
1680 static char*
1681 wstr_to_str(const wchar_t* wstr)
1682 {
1683     BOOL used_default = FALSE;
1684     size_t wlen = wcslen(wstr) + 1;
1685     int len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, wstr, wlen,
1686                                    NULL, 0, NULL, NULL);
1687     char* str = (char*)malloc(len);
1688     if (!str)
1689         out_of_memory();
1690     WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, wstr, wlen,
1691                         str, len, NULL, &used_default);
1692     return str;
1693 }
1694
1695 /* The win32_ansipath() function takes a Unicode filename and converts it
1696  * into the current Windows codepage. If some characters cannot be mapped,
1697  * then it will convert the short name instead.
1698  *
1699  * The buffer to the ansi pathname must be freed with win32_free() when it
1700  * it no longer needed.
1701  *
1702  * The argument to win32_ansipath() must exist before this function is
1703  * called; otherwise there is no way to determine the short path name.
1704  *
1705  * Ideas for future refinement:
1706  * - Only convert those segments of the path that are not in the current
1707  *   codepage, but leave the other segments in their long form.
1708  * - If the resulting name is longer than MAX_PATH, start converting
1709  *   additional path segments into short names until the full name
1710  *   is shorter than MAX_PATH.  Shorten the filename part last!
1711  */
1712 DllExport char *
1713 win32_ansipath(const WCHAR *widename)
1714 {
1715     char *name;
1716     BOOL use_default = FALSE;
1717     size_t widelen = wcslen(widename)+1;
1718     int len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, widename, widelen,
1719                                   NULL, 0, NULL, NULL);
1720     name = (char*)win32_malloc(len);
1721     if (!name)
1722         out_of_memory();
1723
1724     WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, widename, widelen,
1725                         name, len, NULL, &use_default);
1726     if (use_default) {
1727         DWORD shortlen = GetShortPathNameW(widename, NULL, 0);
1728         if (shortlen) {
1729             WCHAR *shortname = (WCHAR*)win32_malloc(shortlen*sizeof(WCHAR));
1730             if (!shortname)
1731                 out_of_memory();
1732             shortlen = GetShortPathNameW(widename, shortname, shortlen)+1;
1733
1734             len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, shortname, shortlen,
1735                                       NULL, 0, NULL, NULL);
1736             name = (char*)win32_realloc(name, len);
1737             if (!name)
1738                 out_of_memory();
1739             WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, shortname, shortlen,
1740                                 name, len, NULL, NULL);
1741             win32_free(shortname);
1742         }
1743     }
1744     return name;
1745 }
1746
1747 /* the returned string must be freed with win32_freeenvironmentstrings which is
1748  * implemented as a macro
1749  * void win32_freeenvironmentstrings(void* block)
1750  */
1751 DllExport char *
1752 win32_getenvironmentstrings(void)
1753 {
1754     LPWSTR lpWStr, lpWTmp;
1755     LPSTR lpStr, lpTmp;
1756     DWORD env_len, wenvstrings_len = 0, aenvstrings_len = 0;
1757
1758     /* Get the process environment strings */
1759     lpWTmp = lpWStr = (LPWSTR) GetEnvironmentStringsW();
1760     for (wenvstrings_len = 1; *lpWTmp != '\0'; lpWTmp += env_len + 1) {
1761         env_len = wcslen(lpWTmp);
1762         /* calculate the size of the environment strings */
1763         wenvstrings_len += env_len + 1;
1764     }
1765
1766     /* Get the number of bytes required to store the ACP encoded string */
1767     aenvstrings_len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, 
1768                                           lpWStr, wenvstrings_len, NULL, 0, NULL, NULL);
1769     lpTmp = lpStr = (char *)win32_calloc(aenvstrings_len, sizeof(char));
1770     if(!lpTmp)
1771         out_of_memory();
1772
1773     /* Convert the string from UTF-16 encoding to ACP encoding */
1774     WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, lpWStr, wenvstrings_len, lpStr, 
1775                         aenvstrings_len, NULL, NULL);
1776
1777     FreeEnvironmentStringsW(lpWStr);
1778
1779     return(lpStr);
1780 }
1781
1782 DllExport char *
1783 win32_getenv(const char *name)
1784 {
1785     dTHX;
1786     DWORD needlen;
1787     SV *curitem = NULL;
1788     DWORD last_err;
1789
1790     needlen = GetEnvironmentVariableA(name,NULL,0);
1791     if (needlen != 0) {
1792         curitem = sv_2mortal(newSVpvs(""));
1793         do {
1794             SvGROW(curitem, needlen+1);
1795             needlen = GetEnvironmentVariableA(name,SvPVX(curitem),
1796                                               needlen);
1797         } while (needlen >= SvLEN(curitem));
1798         SvCUR_set(curitem, needlen);
1799     }
1800     else {
1801         last_err = GetLastError();
1802         if (last_err == ERROR_NOT_ENOUGH_MEMORY) {
1803             /* It appears the variable is in the env, but the Win32 API
1804                doesn't have a canned way of getting it.  So we fall back to
1805                grabbing the whole env and pulling this value out if possible */
1806             char *envv = GetEnvironmentStrings();
1807             char *cur = envv;
1808             STRLEN len;
1809             while (*cur) {
1810                 char *end = strchr(cur,'=');
1811                 if (end && end != cur) {
1812                     *end = '\0';
1813                     if (!strcmp(cur,name)) {
1814                         curitem = sv_2mortal(newSVpv(end+1,0));
1815                         *end = '=';
1816                         break;
1817                     }
1818                     *end = '=';
1819                     cur = end + strlen(end+1)+2;
1820                 }
1821                 else if ((len = strlen(cur)))
1822                     cur += len+1;
1823             }
1824             FreeEnvironmentStrings(envv);
1825         }
1826         else {
1827             /* last ditch: allow any environment variables that begin with 'PERL'
1828                to be obtained from the registry, if found there */
1829             if (strncmp(name, "PERL", 4) == 0)
1830                 (void)get_regstr(name, &curitem);
1831         }
1832     }
1833     if (curitem && SvCUR(curitem))
1834         return SvPVX(curitem);
1835
1836     return NULL;
1837 }
1838
1839 DllExport int
1840 win32_putenv(const char *name)
1841 {
1842     char* curitem;
1843     char* val;
1844     int relval = -1;
1845
1846     if (name) {
1847         curitem = (char *) win32_malloc(strlen(name)+1);
1848         strcpy(curitem, name);
1849         val = strchr(curitem, '=');
1850         if (val) {
1851             /* The sane way to deal with the environment.
1852              * Has these advantages over putenv() & co.:
1853              *  * enables us to store a truly empty value in the
1854              *    environment (like in UNIX).
1855              *  * we don't have to deal with RTL globals, bugs and leaks
1856              *    (specifically, see http://support.microsoft.com/kb/235601).
1857              *  * Much faster.
1858              * Why you may want to use the RTL environment handling
1859              * (previously enabled by USE_WIN32_RTL_ENV):
1860              *  * environ[] and RTL functions will not reflect changes,
1861              *    which might be an issue if extensions want to access
1862              *    the env. via RTL.  This cuts both ways, since RTL will
1863              *    not see changes made by extensions that call the Win32
1864              *    functions directly, either.
1865              * GSAR 97-06-07
1866              */
1867             *val++ = '\0';
1868             if (SetEnvironmentVariableA(curitem, *val ? val : NULL))
1869                 relval = 0;
1870         }
1871         win32_free(curitem);
1872     }
1873     return relval;
1874 }
1875
1876 static long
1877 filetime_to_clock(PFILETIME ft)
1878 {
1879     __int64 qw = ft->dwHighDateTime;
1880     qw <<= 32;
1881     qw |= ft->dwLowDateTime;
1882     qw /= 10000;  /* File time ticks at 0.1uS, clock at 1mS */
1883     return (long) qw;
1884 }
1885
1886 DllExport int
1887 win32_times(struct tms *timebuf)
1888 {
1889     FILETIME user;
1890     FILETIME kernel;
1891     FILETIME dummy;
1892     clock_t process_time_so_far = clock();
1893     if (GetProcessTimes(GetCurrentProcess(), &dummy, &dummy,
1894                         &kernel,&user)) {
1895         timebuf->tms_utime = filetime_to_clock(&user);
1896         timebuf->tms_stime = filetime_to_clock(&kernel);
1897         timebuf->tms_cutime = 0;
1898         timebuf->tms_cstime = 0;
1899     } else {
1900         /* That failed - e.g. Win95 fallback to clock() */
1901         timebuf->tms_utime = process_time_so_far;
1902         timebuf->tms_stime = 0;
1903         timebuf->tms_cutime = 0;
1904         timebuf->tms_cstime = 0;
1905     }
1906     return process_time_so_far;
1907 }
1908
1909 /* fix utime() so it works on directories in NT */
1910 static BOOL
1911 filetime_from_time(PFILETIME pFileTime, time_t Time)
1912 {
1913     struct tm *pTM = localtime(&Time);
1914     SYSTEMTIME SystemTime;
1915     FILETIME LocalTime;
1916
1917     if (pTM == NULL)
1918         return FALSE;
1919
1920     SystemTime.wYear   = pTM->tm_year + 1900;
1921     SystemTime.wMonth  = pTM->tm_mon + 1;
1922     SystemTime.wDay    = pTM->tm_mday;
1923     SystemTime.wHour   = pTM->tm_hour;
1924     SystemTime.wMinute = pTM->tm_min;
1925     SystemTime.wSecond = pTM->tm_sec;
1926     SystemTime.wMilliseconds = 0;
1927
1928     return SystemTimeToFileTime(&SystemTime, &LocalTime) &&
1929            LocalFileTimeToFileTime(&LocalTime, pFileTime);
1930 }
1931
1932 DllExport int
1933 win32_unlink(const char *filename)
1934 {
1935     dTHX;
1936     int ret;
1937     DWORD attrs;
1938
1939     filename = PerlDir_mapA(filename);
1940     attrs = GetFileAttributesA(filename);
1941     if (attrs == 0xFFFFFFFF) {
1942         errno = ENOENT;
1943         return -1;
1944     }
1945     if (attrs & FILE_ATTRIBUTE_READONLY) {
1946         (void)SetFileAttributesA(filename, attrs & ~FILE_ATTRIBUTE_READONLY);
1947         ret = unlink(filename);
1948         if (ret == -1)
1949             (void)SetFileAttributesA(filename, attrs);
1950     }
1951     else
1952         ret = unlink(filename);
1953     return ret;
1954 }
1955
1956 DllExport int
1957 win32_utime(const char *filename, struct utimbuf *times)
1958 {
1959     dTHX;
1960     HANDLE handle;
1961     FILETIME ftCreate;
1962     FILETIME ftAccess;
1963     FILETIME ftWrite;
1964     struct utimbuf TimeBuffer;
1965     int rc;
1966
1967     filename = PerlDir_mapA(filename);
1968     rc = utime(filename, times);
1969
1970     /* EACCES: path specifies directory or readonly file */
1971     if (rc == 0 || errno != EACCES)
1972         return rc;
1973
1974     if (times == NULL) {
1975         times = &TimeBuffer;
1976         time(&times->actime);
1977         times->modtime = times->actime;
1978     }
1979
1980     /* This will (and should) still fail on readonly files */
1981     handle = CreateFileA(filename, GENERIC_READ | GENERIC_WRITE,
1982                          FILE_SHARE_READ | FILE_SHARE_DELETE, NULL,
1983                          OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL);
1984     if (handle == INVALID_HANDLE_VALUE)
1985         return rc;
1986
1987     if (GetFileTime(handle, &ftCreate, &ftAccess, &ftWrite) &&
1988         filetime_from_time(&ftAccess, times->actime) &&
1989         filetime_from_time(&ftWrite, times->modtime) &&
1990         SetFileTime(handle, &ftCreate, &ftAccess, &ftWrite))
1991     {
1992         rc = 0;
1993     }
1994
1995     CloseHandle(handle);
1996     return rc;
1997 }
1998
1999 typedef union {
2000     unsigned __int64    ft_i64;
2001     FILETIME            ft_val;
2002 } FT_t;
2003
2004 #ifdef __GNUC__
2005 #define Const64(x) x##LL
2006 #else
2007 #define Const64(x) x##i64
2008 #endif
2009 /* Number of 100 nanosecond units from 1/1/1601 to 1/1/1970 */
2010 #define EPOCH_BIAS  Const64(116444736000000000)
2011
2012 /* NOTE: This does not compute the timezone info (doing so can be expensive,
2013  * and appears to be unsupported even by glibc) */
2014 DllExport int
2015 win32_gettimeofday(struct timeval *tp, void *not_used)
2016 {
2017     FT_t ft;
2018
2019     /* this returns time in 100-nanosecond units  (i.e. tens of usecs) */
2020     GetSystemTimeAsFileTime(&ft.ft_val);
2021
2022     /* seconds since epoch */
2023     tp->tv_sec = (long)((ft.ft_i64 - EPOCH_BIAS) / Const64(10000000));
2024
2025     /* microseconds remaining */
2026     tp->tv_usec = (long)((ft.ft_i64 / Const64(10)) % Const64(1000000));
2027
2028     return 0;
2029 }
2030
2031 DllExport int
2032 win32_uname(struct utsname *name)
2033 {
2034     struct hostent *hep;
2035     STRLEN nodemax = sizeof(name->nodename)-1;
2036
2037     /* sysname */
2038     switch (g_osver.dwPlatformId) {
2039     case VER_PLATFORM_WIN32_WINDOWS:
2040         strcpy(name->sysname, "Windows");
2041         break;
2042     case VER_PLATFORM_WIN32_NT:
2043         strcpy(name->sysname, "Windows NT");
2044         break;
2045     case VER_PLATFORM_WIN32s:
2046         strcpy(name->sysname, "Win32s");
2047         break;
2048     default:
2049         strcpy(name->sysname, "Win32 Unknown");
2050         break;
2051     }
2052
2053     /* release */
2054     sprintf(name->release, "%d.%d",
2055             g_osver.dwMajorVersion, g_osver.dwMinorVersion);
2056
2057     /* version */
2058     sprintf(name->version, "Build %d",
2059             g_osver.dwPlatformId == VER_PLATFORM_WIN32_NT
2060             ? g_osver.dwBuildNumber : (g_osver.dwBuildNumber & 0xffff));
2061     if (g_osver.szCSDVersion[0]) {
2062         char *buf = name->version + strlen(name->version);
2063         sprintf(buf, " (%s)", g_osver.szCSDVersion);
2064     }
2065
2066     /* nodename */
2067     hep = win32_gethostbyname("localhost");
2068     if (hep) {
2069         STRLEN len = strlen(hep->h_name);
2070         if (len <= nodemax) {
2071             strcpy(name->nodename, hep->h_name);
2072         }
2073         else {
2074             strncpy(name->nodename, hep->h_name, nodemax);
2075             name->nodename[nodemax] = '\0';
2076         }
2077     }
2078     else {
2079         DWORD sz = nodemax;
2080         if (!GetComputerName(name->nodename, &sz))
2081             *name->nodename = '\0';
2082     }
2083
2084     /* machine (architecture) */
2085     {
2086         SYSTEM_INFO info;
2087         DWORD procarch;
2088         char *arch;
2089         GetSystemInfo(&info);
2090
2091 #if (defined(__MINGW32__) && !defined(_ANONYMOUS_UNION) && !defined(__MINGW_EXTENSION))
2092         procarch = info.u.s.wProcessorArchitecture;
2093 #else
2094         procarch = info.wProcessorArchitecture;
2095 #endif
2096         switch (procarch) {
2097         case PROCESSOR_ARCHITECTURE_INTEL:
2098             arch = "x86"; break;
2099         case PROCESSOR_ARCHITECTURE_IA64:
2100             arch = "ia64"; break;
2101         case PROCESSOR_ARCHITECTURE_AMD64:
2102             arch = "amd64"; break;
2103         case PROCESSOR_ARCHITECTURE_UNKNOWN:
2104             arch = "unknown"; break;
2105         default:
2106             sprintf(name->machine, "unknown(0x%x)", procarch);
2107             arch = name->machine;
2108             break;
2109         }
2110         if (name->machine != arch)
2111             strcpy(name->machine, arch);
2112     }
2113     return 0;
2114 }
2115
2116 /* Timing related stuff */
2117
2118 int
2119 do_raise(pTHX_ int sig) 
2120 {
2121     if (sig < SIG_SIZE) {
2122         Sighandler_t handler = w32_sighandler[sig];
2123         if (handler == SIG_IGN) {
2124             return 0;
2125         }
2126         else if (handler != SIG_DFL) {
2127             (*handler)(sig);
2128             return 0;
2129         }
2130         else {
2131             /* Choose correct default behaviour */
2132             switch (sig) {
2133 #ifdef SIGCLD
2134                 case SIGCLD:
2135 #endif
2136 #ifdef SIGCHLD
2137                 case SIGCHLD:
2138 #endif
2139                 case 0:
2140                     return 0;
2141                 case SIGTERM:
2142                 default:
2143                     break;
2144             }
2145         }
2146     }
2147     /* Tell caller to exit thread/process as appropriate */
2148     return 1;
2149 }
2150
2151 void
2152 sig_terminate(pTHX_ int sig)
2153 {
2154     Perl_warn(aTHX_ "Terminating on signal SIG%s(%d)\n",PL_sig_name[sig], sig);
2155     /* exit() seems to be safe, my_exit() or die() is a problem in ^C 
2156        thread 
2157      */
2158     exit(sig);
2159 }
2160
2161 DllExport int
2162 win32_async_check(pTHX)
2163 {
2164     MSG msg;
2165     HWND hwnd = w32_message_hwnd;
2166
2167     /* Reset w32_poll_count before doing anything else, incase we dispatch
2168      * messages that end up calling back into perl */
2169     w32_poll_count = 0;
2170
2171     if (hwnd != INVALID_HANDLE_VALUE) {
2172         /* Passing PeekMessage -1 as HWND (2nd arg) only gets PostThreadMessage() messages
2173         * and ignores window messages - should co-exist better with windows apps e.g. Tk
2174         */
2175         if (hwnd == NULL)
2176             hwnd = (HWND)-1;
2177
2178         while (PeekMessage(&msg, hwnd, WM_TIMER,    WM_TIMER,    PM_REMOVE|PM_NOYIELD) ||
2179                PeekMessage(&msg, hwnd, WM_USER_MIN, WM_USER_MAX, PM_REMOVE|PM_NOYIELD))
2180         {
2181             /* re-post a WM_QUIT message (we'll mark it as read later) */
2182             if(msg.message == WM_QUIT) {
2183                 PostQuitMessage((int)msg.wParam);
2184                 break;
2185             }
2186
2187             if(!CallMsgFilter(&msg, MSGF_USER))
2188             {
2189                 TranslateMessage(&msg);
2190                 DispatchMessage(&msg);
2191             }
2192         }
2193     }
2194
2195     /* Call PeekMessage() to mark all pending messages in the queue as "old".
2196      * This is necessary when we are being called by win32_msgwait() to
2197      * make sure MsgWaitForMultipleObjects() stops reporting the same waiting
2198      * message over and over.  An example how this can happen is when
2199      * Perl is calling win32_waitpid() inside a GUI application and the GUI
2200      * is generating messages before the process terminated.
2201      */
2202     PeekMessage(&msg, NULL, 0, 0, PM_NOREMOVE|PM_NOYIELD);
2203
2204     /* Above or other stuff may have set a signal flag */
2205     if (PL_sig_pending)
2206         despatch_signals();
2207     
2208     return 1;
2209 }
2210
2211 /* This function will not return until the timeout has elapsed, or until
2212  * one of the handles is ready. */
2213 DllExport DWORD
2214 win32_msgwait(pTHX_ DWORD count, LPHANDLE handles, DWORD timeout, LPDWORD resultp)
2215 {
2216     /* We may need several goes at this - so compute when we stop */
2217     FT_t ticks = {0};
2218     unsigned __int64 endtime = timeout;
2219     if (timeout != INFINITE) {
2220         GetSystemTimeAsFileTime(&ticks.ft_val);
2221         ticks.ft_i64 /= 10000;
2222         endtime += ticks.ft_i64;
2223     }
2224     /* This was a race condition. Do not let a non INFINITE timeout to
2225      * MsgWaitForMultipleObjects roll under 0 creating a near
2226      * infinity/~(UINT32)0 timeout which will appear as a deadlock to the
2227      * user who did a CORE perl function with a non infinity timeout,
2228      * sleep for example.  This is 64 to 32 truncation minefield.
2229      *
2230      * This scenario can only be created if the timespan from the return of
2231      * MsgWaitForMultipleObjects to GetSystemTimeAsFileTime exceeds 1 ms. To
2232      * generate the scenario, manual breakpoints in a C debugger are required,
2233      * or a context switch occurred in win32_async_check in PeekMessage, or random
2234      * messages are delivered to the *thread* message queue of the Perl thread
2235      * from another process (msctf.dll doing IPC among its instances, VS debugger
2236      * causes msctf.dll to be loaded into Perl by kernel), see [perl #33096].
2237      */
2238     while (ticks.ft_i64 <= endtime) {
2239         /* if timeout's type is lengthened, remember to split 64b timeout
2240          * into multiple non-infinity runs of MWFMO */
2241         DWORD result = MsgWaitForMultipleObjects(count, handles, FALSE,
2242                                                 (DWORD)(endtime - ticks.ft_i64),
2243                                                 QS_POSTMESSAGE|QS_TIMER|QS_SENDMESSAGE);
2244         if (resultp)
2245            *resultp = result;
2246         if (result == WAIT_TIMEOUT) {
2247             /* Ran out of time - explicit return of zero to avoid -ve if we
2248                have scheduling issues
2249              */
2250             return 0;
2251         }
2252         if (timeout != INFINITE) {
2253             GetSystemTimeAsFileTime(&ticks.ft_val);
2254             ticks.ft_i64 /= 10000;
2255         }
2256         if (result == WAIT_OBJECT_0 + count) {
2257             /* Message has arrived - check it */
2258             (void)win32_async_check(aTHX);
2259         }
2260         else {
2261            /* Not timeout or message - one of handles is ready */
2262            break;
2263         }
2264     }
2265     /* If we are past the end say zero */
2266     if (!ticks.ft_i64 || ticks.ft_i64 > endtime)
2267         return 0;
2268     /* compute time left to wait */
2269     ticks.ft_i64 = endtime - ticks.ft_i64;
2270     /* if more ms than DWORD, then return max DWORD */
2271     return ticks.ft_i64 <= UINT_MAX ? (DWORD)ticks.ft_i64 : UINT_MAX;
2272 }
2273
2274 int
2275 win32_internal_wait(pTHX_ int *status, DWORD timeout)
2276 {
2277     /* XXX this wait emulation only knows about processes
2278      * spawned via win32_spawnvp(P_NOWAIT, ...).
2279      */
2280     int i, retval;
2281     DWORD exitcode, waitcode;
2282
2283 #ifdef USE_ITHREADS
2284     if (w32_num_pseudo_children) {
2285         win32_msgwait(aTHX_ w32_num_pseudo_children, w32_pseudo_child_handles,
2286                       timeout, &waitcode);
2287         /* Time out here if there are no other children to wait for. */
2288         if (waitcode == WAIT_TIMEOUT) {
2289             if (!w32_num_children) {
2290                 return 0;
2291             }
2292         }
2293         else if (waitcode != WAIT_FAILED) {
2294             if (waitcode >= WAIT_ABANDONED_0
2295                 && waitcode < WAIT_ABANDONED_0 + w32_num_pseudo_children)
2296                 i = waitcode - WAIT_ABANDONED_0;
2297             else
2298                 i = waitcode - WAIT_OBJECT_0;
2299             if (GetExitCodeThread(w32_pseudo_child_handles[i], &exitcode)) {
2300                 *status = (int)((exitcode & 0xff) << 8);
2301                 retval = (int)w32_pseudo_child_pids[i];
2302                 remove_dead_pseudo_process(i);
2303                 return -retval;
2304             }
2305         }
2306     }
2307 #endif
2308
2309     if (!w32_num_children) {
2310         errno = ECHILD;
2311         return -1;
2312     }
2313
2314     /* if a child exists, wait for it to die */
2315     win32_msgwait(aTHX_ w32_num_children, w32_child_handles, timeout, &waitcode);
2316     if (waitcode == WAIT_TIMEOUT) {
2317         return 0;
2318     }
2319     if (waitcode != WAIT_FAILED) {
2320         if (waitcode >= WAIT_ABANDONED_0
2321             && waitcode < WAIT_ABANDONED_0 + w32_num_children)
2322             i = waitcode - WAIT_ABANDONED_0;
2323         else
2324             i = waitcode - WAIT_OBJECT_0;
2325         if (GetExitCodeProcess(w32_child_handles[i], &exitcode) ) {
2326             *status = (int)((exitcode & 0xff) << 8);
2327             retval = (int)w32_child_pids[i];
2328             remove_dead_process(i);
2329             return retval;
2330         }
2331     }
2332
2333     errno = GetLastError();
2334     return -1;
2335 }
2336
2337 DllExport int
2338 win32_waitpid(int pid, int *status, int flags)
2339 {
2340     dTHX;
2341     DWORD timeout = (flags & WNOHANG) ? 0 : INFINITE;
2342     int retval = -1;
2343     long child;
2344     if (pid == -1)                              /* XXX threadid == 1 ? */
2345         return win32_internal_wait(aTHX_ status, timeout);
2346 #ifdef USE_ITHREADS
2347     else if (pid < 0) {
2348         child = find_pseudo_pid(aTHX_ -pid);
2349         if (child >= 0) {
2350             HANDLE hThread = w32_pseudo_child_handles[child];
2351             DWORD waitcode;
2352             win32_msgwait(aTHX_ 1, &hThread, timeout, &waitcode);
2353             if (waitcode == WAIT_TIMEOUT) {
2354                 return 0;
2355             }
2356             else if (waitcode == WAIT_OBJECT_0) {
2357                 if (GetExitCodeThread(hThread, &waitcode)) {
2358                     *status = (int)((waitcode & 0xff) << 8);
2359                     retval = (int)w32_pseudo_child_pids[child];
2360                     remove_dead_pseudo_process(child);
2361                     return -retval;
2362                 }
2363             }
2364             else
2365                 errno = ECHILD;
2366         }
2367     }
2368 #endif
2369     else {
2370         HANDLE hProcess;
2371         DWORD waitcode;
2372         child = find_pid(aTHX_ pid);
2373         if (child >= 0) {
2374             hProcess = w32_child_handles[child];
2375             win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
2376             if (waitcode == WAIT_TIMEOUT) {
2377                 return 0;
2378             }
2379             else if (waitcode == WAIT_OBJECT_0) {
2380                 if (GetExitCodeProcess(hProcess, &waitcode)) {
2381                     *status = (int)((waitcode & 0xff) << 8);
2382                     retval = (int)w32_child_pids[child];
2383                     remove_dead_process(child);
2384                     return retval;
2385                 }
2386             }
2387             else
2388                 errno = ECHILD;
2389         }
2390         else {
2391             hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE, pid);
2392             if (hProcess) {
2393                 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
2394                 if (waitcode == WAIT_TIMEOUT) {
2395                     CloseHandle(hProcess);
2396                     return 0;
2397                 }
2398                 else if (waitcode == WAIT_OBJECT_0) {
2399                     if (GetExitCodeProcess(hProcess, &waitcode)) {
2400                         *status = (int)((waitcode & 0xff) << 8);
2401                         CloseHandle(hProcess);
2402                         return pid;
2403                     }
2404                 }
2405                 CloseHandle(hProcess);
2406             }
2407             else
2408                 errno = ECHILD;
2409         }
2410     }
2411     return retval >= 0 ? pid : retval;
2412 }
2413
2414 DllExport int
2415 win32_wait(int *status)
2416 {
2417     dTHX;
2418     return win32_internal_wait(aTHX_ status, INFINITE);
2419 }
2420
2421 DllExport unsigned int
2422 win32_sleep(unsigned int t)
2423 {
2424     dTHX;
2425     /* Win32 times are in ms so *1000 in and /1000 out */
2426     if (t > UINT_MAX / 1000) {
2427         Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
2428                         "sleep(%lu) too large", t);
2429     }
2430     return win32_msgwait(aTHX_ 0, NULL, t * 1000, NULL) / 1000;
2431 }
2432
2433 DllExport unsigned int
2434 win32_alarm(unsigned int sec)
2435 {
2436     /*
2437      * the 'obvious' implentation is SetTimer() with a callback
2438      * which does whatever receiving SIGALRM would do
2439      * we cannot use SIGALRM even via raise() as it is not
2440      * one of the supported codes in <signal.h>
2441      */
2442     dTHX;
2443
2444     if (w32_message_hwnd == INVALID_HANDLE_VALUE)
2445         w32_message_hwnd = win32_create_message_window();
2446
2447     if (sec) {
2448         if (w32_message_hwnd == NULL)
2449             w32_timerid = SetTimer(NULL, w32_timerid, sec*1000, NULL);
2450         else {
2451             w32_timerid = 1;
2452             SetTimer(w32_message_hwnd, w32_timerid, sec*1000, NULL);
2453         }
2454     }
2455     else {
2456         if (w32_timerid) {
2457             KillTimer(w32_message_hwnd, w32_timerid);
2458             w32_timerid = 0;
2459         }
2460     }
2461     return 0;
2462 }
2463
2464 extern char *   des_fcrypt(const char *txt, const char *salt, char *cbuf);
2465
2466 DllExport char *
2467 win32_crypt(const char *txt, const char *salt)
2468 {
2469     dTHX;
2470     return des_fcrypt(txt, salt, w32_crypt_buffer);
2471 }
2472
2473 /* simulate flock by locking a range on the file */
2474
2475 #define LK_LEN          0xffff0000
2476
2477 DllExport int
2478 win32_flock(int fd, int oper)
2479 {
2480     OVERLAPPED o;
2481     int i = -1;
2482     HANDLE fh;
2483
2484     fh = (HANDLE)_get_osfhandle(fd);
2485     if (fh == (HANDLE)-1)  /* _get_osfhandle() already sets errno to EBADF */
2486         return -1;
2487
2488     memset(&o, 0, sizeof(o));
2489
2490     switch(oper) {
2491     case LOCK_SH:               /* shared lock */
2492         if (LockFileEx(fh, 0, 0, LK_LEN, 0, &o))
2493             i = 0;
2494         break;
2495     case LOCK_EX:               /* exclusive lock */
2496         if (LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK, 0, LK_LEN, 0, &o))
2497             i = 0;
2498         break;
2499     case LOCK_SH|LOCK_NB:       /* non-blocking shared lock */
2500         if (LockFileEx(fh, LOCKFILE_FAIL_IMMEDIATELY, 0, LK_LEN, 0, &o))
2501             i = 0;
2502         break;
2503     case LOCK_EX|LOCK_NB:       /* non-blocking exclusive lock */
2504         if (LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK|LOCKFILE_FAIL_IMMEDIATELY,
2505                        0, LK_LEN, 0, &o))
2506             i = 0;
2507         break;
2508     case LOCK_UN:               /* unlock lock */
2509         if (UnlockFileEx(fh, 0, LK_LEN, 0, &o))
2510             i = 0;
2511         break;
2512     default:                    /* unknown */
2513         errno = EINVAL;
2514         return -1;
2515     }
2516     if (i == -1) {
2517         if (GetLastError() == ERROR_LOCK_VIOLATION)
2518             errno = EWOULDBLOCK;
2519         else
2520             errno = EINVAL;
2521     }
2522     return i;
2523 }
2524
2525 #undef LK_LEN
2526
2527 extern int convert_wsa_error_to_errno(int wsaerr); /* in win32sck.c */
2528
2529 /* Get the errno value corresponding to the given err. This function is not
2530  * intended to handle conversion of general GetLastError() codes. It only exists
2531  * to translate Windows sockets error codes from WSAGetLastError(). Such codes
2532  * used to be assigned to errno/$! in earlier versions of perl; this function is
2533  * used to catch any old Perl code which is still trying to assign such values
2534  * to $! and convert them to errno values instead.
2535  */
2536 int
2537 win32_get_errno(int err)
2538 {
2539     return convert_wsa_error_to_errno(err);
2540 }
2541
2542 /*
2543  *  redirected io subsystem for all XS modules
2544  *
2545  */
2546
2547 DllExport int *
2548 win32_errno(void)
2549 {
2550     return (&errno);
2551 }
2552
2553 DllExport char ***
2554 win32_environ(void)
2555 {
2556     return (&(_environ));
2557 }
2558
2559 /* the rest are the remapped stdio routines */
2560 DllExport FILE *
2561 win32_stderr(void)
2562 {
2563     return (stderr);
2564 }
2565
2566 DllExport FILE *
2567 win32_stdin(void)
2568 {
2569     return (stdin);
2570 }
2571
2572 DllExport FILE *
2573 win32_stdout(void)
2574 {
2575     return (stdout);
2576 }
2577
2578 DllExport int
2579 win32_ferror(FILE *fp)
2580 {
2581     return (ferror(fp));
2582 }
2583
2584
2585 DllExport int
2586 win32_feof(FILE *fp)
2587 {
2588     return (feof(fp));
2589 }
2590
2591 #ifdef ERRNO_HAS_POSIX_SUPPLEMENT
2592 extern int convert_errno_to_wsa_error(int err); /* in win32sck.c */
2593 #endif
2594
2595 /*
2596  * Since the errors returned by the socket error function
2597  * WSAGetLastError() are not known by the library routine strerror
2598  * we have to roll our own to cover the case of socket errors
2599  * that could not be converted to regular errno values by
2600  * get_last_socket_error() in win32/win32sck.c.
2601  */
2602
2603 DllExport char *
2604 win32_strerror(int e)
2605 {
2606 #if !defined __MINGW32__      /* compiler intolerance */
2607     extern int sys_nerr;
2608 #endif
2609
2610     if (e < 0 || e > sys_nerr) {
2611         dTHXa(NULL);
2612         if (e < 0)
2613             e = GetLastError();
2614 #ifdef ERRNO_HAS_POSIX_SUPPLEMENT
2615         /* VC10+ and some MinGW/gcc-4.8+ define a "POSIX supplement" of errno
2616          * values ranging from EADDRINUSE (100) to EWOULDBLOCK (140), but
2617          * sys_nerr is still 43 and strerror() returns "Unknown error" for them.
2618          * We must therefore still roll our own messages for these codes, and
2619          * additionally map them to corresponding Windows (sockets) error codes
2620          * first to avoid getting the wrong system message.
2621          */
2622         else if (e >= EADDRINUSE && e <= EWOULDBLOCK) {
2623             e = convert_errno_to_wsa_error(e);
2624         }
2625 #endif
2626
2627         aTHXa(PERL_GET_THX);
2628         if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM
2629                          |FORMAT_MESSAGE_IGNORE_INSERTS, NULL, e, 0,
2630                           w32_strerror_buffer, sizeof(w32_strerror_buffer),
2631                           NULL) == 0)
2632         {
2633             strcpy(w32_strerror_buffer, "Unknown Error");
2634         }
2635         return w32_strerror_buffer;
2636     }
2637 #undef strerror
2638     return strerror(e);
2639 #define strerror win32_strerror
2640 }
2641
2642 DllExport void
2643 win32_str_os_error(void *sv, DWORD dwErr)
2644 {
2645     DWORD dwLen;
2646     char *sMsg;
2647     dwLen = FormatMessageA(FORMAT_MESSAGE_ALLOCATE_BUFFER
2648                           |FORMAT_MESSAGE_IGNORE_INSERTS
2649                           |FORMAT_MESSAGE_FROM_SYSTEM, NULL,
2650                            dwErr, 0, (char *)&sMsg, 1, NULL);
2651     /* strip trailing whitespace and period */
2652     if (0 < dwLen) {
2653         do {
2654             --dwLen;    /* dwLen doesn't include trailing null */
2655         } while (0 < dwLen && isSPACE(sMsg[dwLen]));
2656         if ('.' != sMsg[dwLen])
2657             dwLen++;
2658         sMsg[dwLen] = '\0';
2659     }
2660     if (0 == dwLen) {
2661         sMsg = (char*)LocalAlloc(0, 64/**sizeof(TCHAR)*/);
2662         if (sMsg)
2663             dwLen = sprintf(sMsg,
2664                             "Unknown error #0x%lX (lookup 0x%lX)",
2665                             dwErr, GetLastError());
2666     }
2667     if (sMsg) {
2668         dTHX;
2669         sv_setpvn((SV*)sv, sMsg, dwLen);
2670         LocalFree(sMsg);
2671     }
2672 }
2673
2674 DllExport int
2675 win32_fprintf(FILE *fp, const char *format, ...)
2676 {
2677     va_list marker;
2678     va_start(marker, format);     /* Initialize variable arguments. */
2679
2680     return (vfprintf(fp, format, marker));
2681 }
2682
2683 DllExport int
2684 win32_printf(const char *format, ...)
2685 {
2686     va_list marker;
2687     va_start(marker, format);     /* Initialize variable arguments. */
2688
2689     return (vprintf(format, marker));
2690 }
2691
2692 DllExport int
2693 win32_vfprintf(FILE *fp, const char *format, va_list args)
2694 {
2695     return (vfprintf(fp, format, args));
2696 }
2697
2698 DllExport int
2699 win32_vprintf(const char *format, va_list args)
2700 {
2701     return (vprintf(format, args));
2702 }
2703
2704 DllExport size_t
2705 win32_fread(void *buf, size_t size, size_t count, FILE *fp)
2706 {
2707     return fread(buf, size, count, fp);
2708 }
2709
2710 DllExport size_t
2711 win32_fwrite(const void *buf, size_t size, size_t count, FILE *fp)
2712 {
2713     return fwrite(buf, size, count, fp);
2714 }
2715
2716 #define MODE_SIZE 10
2717
2718 DllExport FILE *
2719 win32_fopen(const char *filename, const char *mode)
2720 {
2721     dTHXa(NULL);
2722     FILE *f;
2723
2724     if (!*filename)
2725         return NULL;
2726
2727     if (stricmp(filename, "/dev/null")==0)
2728         filename = "NUL";
2729
2730     aTHXa(PERL_GET_THX);
2731     f = fopen(PerlDir_mapA(filename), mode);
2732     /* avoid buffering headaches for child processes */
2733     if (f && *mode == 'a')
2734         win32_fseek(f, 0, SEEK_END);
2735     return f;
2736 }
2737
2738 DllExport FILE *
2739 win32_fdopen(int handle, const char *mode)
2740 {
2741     FILE *f;
2742     f = fdopen(handle, (char *) mode);
2743     /* avoid buffering headaches for child processes */
2744     if (f && *mode == 'a')
2745         win32_fseek(f, 0, SEEK_END);
2746     return f;
2747 }
2748
2749 DllExport FILE *
2750 win32_freopen(const char *path, const char *mode, FILE *stream)
2751 {
2752     dTHXa(NULL);
2753     if (stricmp(path, "/dev/null")==0)
2754         path = "NUL";
2755
2756     aTHXa(PERL_GET_THX);
2757     return freopen(PerlDir_mapA(path), mode, stream);
2758 }
2759
2760 DllExport int
2761 win32_fclose(FILE *pf)
2762 {
2763 #ifdef WIN32_NO_SOCKETS
2764     return fclose(pf);
2765 #else
2766     return my_fclose(pf);       /* defined in win32sck.c */
2767 #endif
2768 }
2769
2770 DllExport int
2771 win32_fputs(const char *s,FILE *pf)
2772 {
2773     return fputs(s, pf);
2774 }
2775
2776 DllExport int
2777 win32_fputc(int c,FILE *pf)
2778 {
2779     return fputc(c,pf);
2780 }
2781
2782 DllExport int
2783 win32_ungetc(int c,FILE *pf)
2784 {
2785     return ungetc(c,pf);
2786 }
2787
2788 DllExport int
2789 win32_getc(FILE *pf)
2790 {
2791     return getc(pf);
2792 }
2793
2794 DllExport int
2795 win32_fileno(FILE *pf)
2796 {
2797     return fileno(pf);
2798 }
2799
2800 DllExport void
2801 win32_clearerr(FILE *pf)
2802 {
2803     clearerr(pf);
2804     return;
2805 }
2806
2807 DllExport int
2808 win32_fflush(FILE *pf)
2809 {
2810     return fflush(pf);
2811 }
2812
2813 DllExport Off_t
2814 win32_ftell(FILE *pf)
2815 {
2816 #if defined(WIN64) || defined(USE_LARGE_FILES)
2817     fpos_t pos;
2818     if (fgetpos(pf, &pos))
2819         return -1;
2820     return (Off_t)pos;
2821 #else
2822     return ftell(pf);
2823 #endif
2824 }
2825
2826 DllExport int
2827 win32_fseek(FILE *pf, Off_t offset,int origin)
2828 {
2829 #if defined(WIN64) || defined(USE_LARGE_FILES)
2830     fpos_t pos;
2831     switch (origin) {
2832     case SEEK_CUR:
2833         if (fgetpos(pf, &pos))
2834             return -1;
2835         offset += pos;
2836         break;
2837     case SEEK_END:
2838         fseek(pf, 0, SEEK_END);
2839         pos = _telli64(fileno(pf));
2840         offset += pos;
2841         break;
2842     case SEEK_SET:
2843         break;
2844     default:
2845         errno = EINVAL;
2846         return -1;
2847     }
2848     return fsetpos(pf, &offset);
2849 #else
2850     return fseek(pf, (long)offset, origin);
2851 #endif
2852 }
2853
2854 DllExport int
2855 win32_fgetpos(FILE *pf,fpos_t *p)
2856 {
2857     return fgetpos(pf, p);
2858 }
2859
2860 DllExport int
2861 win32_fsetpos(FILE *pf,const fpos_t *p)
2862 {
2863     return fsetpos(pf, p);
2864 }
2865
2866 DllExport void
2867 win32_rewind(FILE *pf)
2868 {
2869     rewind(pf);
2870     return;
2871 }
2872
2873 DllExport int
2874 win32_tmpfd(void)
2875 {
2876     char prefix[MAX_PATH+1];
2877     char filename[MAX_PATH+1];
2878     DWORD len = GetTempPath(MAX_PATH, prefix);
2879     if (len && len < MAX_PATH) {
2880         if (GetTempFileName(prefix, "plx", 0, filename)) {
2881             HANDLE fh = CreateFile(filename,
2882                                    DELETE | GENERIC_READ | GENERIC_WRITE,
2883                                    0,
2884                                    NULL,
2885                                    CREATE_ALWAYS,
2886                                    FILE_ATTRIBUTE_NORMAL
2887                                    | FILE_FLAG_DELETE_ON_CLOSE,
2888                                    NULL);
2889             if (fh != INVALID_HANDLE_VALUE) {
2890                 int fd = win32_open_osfhandle((intptr_t)fh, 0);
2891                 if (fd >= 0) {
2892                     PERL_DEB(dTHX;)
2893                     DEBUG_p(PerlIO_printf(Perl_debug_log,
2894                                           "Created tmpfile=%s\n",filename));
2895                     return fd;
2896                 }
2897             }
2898         }
2899     }
2900     return -1;
2901 }
2902
2903 DllExport FILE*
2904 win32_tmpfile(void)
2905 {
2906     int fd = win32_tmpfd();
2907     if (fd >= 0)
2908         return win32_fdopen(fd, "w+b");
2909     return NULL;
2910 }
2911
2912 DllExport void
2913 win32_abort(void)
2914 {
2915     abort();
2916     return;
2917 }
2918
2919 DllExport int
2920 win32_fstat(int fd, Stat_t *sbufptr)
2921 {
2922 #if defined(WIN64) || defined(USE_LARGE_FILES)
2923     return _fstati64(fd, sbufptr);
2924 #else
2925     return fstat(fd, sbufptr);
2926 #endif
2927 }
2928
2929 DllExport int
2930 win32_pipe(int *pfd, unsigned int size, int mode)
2931 {
2932     return _pipe(pfd, size, mode);
2933 }
2934
2935 DllExport PerlIO*
2936 win32_popenlist(const char *mode, IV narg, SV **args)
2937 {
2938     get_shell();
2939
2940     return do_popen(mode, NULL, narg, args);
2941 }
2942
2943 STATIC PerlIO*
2944 do_popen(const char *mode, const char *command, IV narg, SV **args) {
2945     int p[2];
2946     int handles[3];
2947     int parent, child;
2948     int stdfd;
2949     int ourmode;
2950     int childpid;
2951     DWORD nhandle;
2952     int lock_held = 0;
2953     const char **args_pvs = NULL;
2954
2955     /* establish which ends read and write */
2956     if (strchr(mode,'w')) {
2957         stdfd = 0;              /* stdin */
2958         parent = 1;
2959         child = 0;
2960         nhandle = STD_INPUT_HANDLE;
2961     }
2962     else if (strchr(mode,'r')) {
2963         stdfd = 1;              /* stdout */
2964         parent = 0;
2965         child = 1;
2966         nhandle = STD_OUTPUT_HANDLE;
2967     }
2968     else
2969         return NULL;
2970
2971     /* set the correct mode */
2972     if (strchr(mode,'b'))
2973         ourmode = O_BINARY;
2974     else if (strchr(mode,'t'))
2975         ourmode = O_TEXT;
2976     else
2977         ourmode = _fmode & (O_TEXT | O_BINARY);
2978
2979     /* the child doesn't inherit handles */
2980     ourmode |= O_NOINHERIT;
2981
2982     if (win32_pipe(p, 512, ourmode) == -1)
2983         return NULL;
2984
2985     /* Previously this code redirected stdin/out temporarily so the
2986        child process inherited those handles, this caused race
2987        conditions when another thread was writing/reading those
2988        handles.
2989
2990        To avoid that we just feed the handles to CreateProcess() so
2991        the handles are redirected only in the child.
2992      */
2993     handles[child] = p[child];
2994     handles[parent] = -1;
2995     handles[2] = -1;
2996
2997     /* CreateProcess() requires inheritable handles */
2998     if (!SetHandleInformation((HANDLE)_get_osfhandle(p[child]), HANDLE_FLAG_INHERIT,
2999                               HANDLE_FLAG_INHERIT)) {
3000         goto cleanup;
3001     }
3002
3003     /* start the child */
3004     {
3005         dTHX;
3006
3007         if (command) {
3008             if ((childpid = do_spawn2_handles(aTHX_ command, EXECF_SPAWN_NOWAIT, handles)) == -1)
3009                 goto cleanup;
3010
3011         }
3012         else {
3013             int i;
3014             const char *exe_name;
3015
3016             Newx(args_pvs, narg + 1 + w32_perlshell_items, const char *);
3017             SAVEFREEPV(args_pvs);
3018             for (i = 0; i < narg; ++i)
3019                 args_pvs[i] = SvPV_nolen(args[i]);
3020             args_pvs[i] = NULL;
3021             exe_name = qualified_path(args_pvs[0], TRUE);
3022             if (!exe_name)
3023                 /* let CreateProcess() try to find it instead */
3024                 exe_name = args_pvs[0];
3025
3026             if ((childpid = do_spawnvp_handles(P_NOWAIT, exe_name, args_pvs, handles)) == -1) {
3027                 goto cleanup;
3028             }
3029         }
3030
3031         win32_close(p[child]);
3032
3033         sv_setiv(*av_fetch(w32_fdpid, p[parent], TRUE), childpid);
3034
3035         /* set process id so that it can be returned by perl's open() */
3036         PL_forkprocess = childpid;
3037     }
3038
3039     /* we have an fd, return a file stream */
3040     return (PerlIO_fdopen(p[parent], (char *)mode));
3041
3042 cleanup:
3043     /* we don't need to check for errors here */
3044     win32_close(p[0]);
3045     win32_close(p[1]);
3046
3047     return (NULL);
3048 }
3049
3050 /*
3051  * a popen() clone that respects PERL5SHELL
3052  *
3053  * changed to return PerlIO* rather than FILE * by BKS, 11-11-2000
3054  */
3055
3056 DllExport PerlIO*
3057 win32_popen(const char *command, const char *mode)
3058 {
3059 #ifdef USE_RTL_POPEN
3060     return _popen(command, mode);
3061 #else
3062     return do_popen(mode, command, 0, NULL);
3063 #endif /* USE_RTL_POPEN */
3064 }
3065
3066 /*
3067  * pclose() clone
3068  */
3069
3070 DllExport int
3071 win32_pclose(PerlIO *pf)
3072 {
3073 #ifdef USE_RTL_POPEN
3074     return _pclose(pf);
3075 #else
3076     dTHX;
3077     int childpid, status;
3078     SV *sv;
3079
3080     sv = *av_fetch(w32_fdpid, PerlIO_fileno(pf), TRUE);
3081
3082     if (SvIOK(sv))
3083         childpid = SvIVX(sv);
3084     else
3085         childpid = 0;
3086
3087     if (!childpid) {
3088         errno = EBADF;
3089         return -1;
3090     }
3091
3092 #ifdef USE_PERLIO
3093     PerlIO_close(pf);
3094 #else
3095     fclose(pf);
3096 #endif
3097     SvIVX(sv) = 0;
3098
3099     if (win32_waitpid(childpid, &status, 0) == -1)
3100         return -1;
3101
3102     return status;
3103
3104 #endif /* USE_RTL_POPEN */
3105 }
3106
3107 DllExport int
3108 win32_link(const char *oldname, const char *newname)
3109 {
3110     dTHXa(NULL);
3111     WCHAR wOldName[MAX_PATH+1];
3112     WCHAR wNewName[MAX_PATH+1];
3113
3114     if (MultiByteToWideChar(CP_ACP, 0, oldname, -1, wOldName, MAX_PATH+1) &&
3115         MultiByteToWideChar(CP_ACP, 0, newname, -1, wNewName, MAX_PATH+1) &&
3116         ((aTHXa(PERL_GET_THX)), wcscpy(wOldName, PerlDir_mapW(wOldName)),
3117         CreateHardLinkW(PerlDir_mapW(wNewName), wOldName, NULL)))
3118     {
3119         return 0;
3120     }
3121     /* This isn't perfect, eg. Win32 returns ERROR_ACCESS_DENIED for
3122        both permissions errors and if the source is a directory, while
3123        POSIX wants EACCES and EPERM respectively.
3124
3125        Determined by experimentation on Windows 7 x64 SP1, since MS
3126        don't document what error codes are returned.
3127     */
3128     switch (GetLastError()) {
3129     case ERROR_BAD_NET_NAME:
3130     case ERROR_BAD_NETPATH:
3131     case ERROR_BAD_PATHNAME:
3132     case ERROR_FILE_NOT_FOUND:
3133     case ERROR_FILENAME_EXCED_RANGE:
3134     case ERROR_INVALID_DRIVE:
3135     case ERROR_PATH_NOT_FOUND:
3136       errno = ENOENT;
3137       break;
3138     case ERROR_ALREADY_EXISTS:
3139       errno = EEXIST;
3140       break;
3141     case ERROR_ACCESS_DENIED:
3142       errno = EACCES;
3143       break;
3144     case ERROR_NOT_SAME_DEVICE:
3145       errno = EXDEV;
3146       break;
3147     case ERROR_DISK_FULL:
3148       errno = ENOSPC;
3149       break;
3150     case ERROR_NOT_ENOUGH_QUOTA:
3151       errno = EDQUOT;
3152       break;
3153     default:
3154       /* ERROR_INVALID_FUNCTION - eg. on a FAT volume */
3155       errno = EINVAL;
3156       break;
3157     }
3158     return -1;
3159 }
3160
3161 DllExport int
3162 win32_rename(const char *oname, const char *newname)
3163 {
3164     char szOldName[MAX_PATH+1];
3165     BOOL bResult;
3166     DWORD dwFlags = MOVEFILE_COPY_ALLOWED;
3167     dTHX;
3168
3169     if (stricmp(newname, oname))
3170         dwFlags |= MOVEFILE_REPLACE_EXISTING;
3171     strcpy(szOldName, PerlDir_mapA(oname));
3172
3173     bResult = MoveFileExA(szOldName,PerlDir_mapA(newname), dwFlags);
3174     if (!bResult) {
3175         DWORD err = GetLastError();
3176         switch (err) {
3177         case ERROR_BAD_NET_NAME:
3178         case ERROR_BAD_NETPATH:
3179         case ERROR_BAD_PATHNAME:
3180         case ERROR_FILE_NOT_FOUND:
3181         case ERROR_FILENAME_EXCED_RANGE:
3182         case ERROR_INVALID_DRIVE:
3183         case ERROR_NO_MORE_FILES:
3184         case ERROR_PATH_NOT_FOUND:
3185             errno = ENOENT;
3186             break;
3187         case ERROR_DISK_FULL:
3188             errno = ENOSPC;
3189             break;
3190         case ERROR_NOT_ENOUGH_QUOTA:
3191             errno = EDQUOT;
3192             break;
3193         default:
3194             errno = EACCES;
3195             break;
3196         }
3197         return -1;
3198     }
3199     return 0;
3200 }
3201
3202 DllExport int
3203 win32_setmode(int fd, int mode)
3204 {
3205     return setmode(fd, mode);
3206 }
3207
3208 DllExport int
3209 win32_chsize(int fd, Off_t size)
3210 {
3211 #if defined(WIN64) || defined(USE_LARGE_FILES)
3212     int retval = 0;
3213     Off_t cur, end, extend;
3214
3215     cur = win32_tell(fd);
3216     if (cur < 0)
3217         return -1;
3218     end = win32_lseek(fd, 0, SEEK_END);
3219     if (end < 0)
3220         return -1;
3221     extend = size - end;
3222     if (extend == 0) {
3223         /* do nothing */
3224     }
3225     else if (extend > 0) {
3226         /* must grow the file, padding with nulls */
3227         char b[4096];
3228         int oldmode = win32_setmode(fd, O_BINARY);
3229         size_t count;
3230         memset(b, '\0', sizeof(b));
3231         do {
3232             count = extend >= sizeof(b) ? sizeof(b) : (size_t)extend;
3233             count = win32_write(fd, b, count);
3234             if ((int)count < 0) {
3235                 retval = -1;
3236                 break;
3237             }
3238         } while ((extend -= count) > 0);
3239         win32_setmode(fd, oldmode);
3240     }
3241     else {
3242         /* shrink the file */
3243         win32_lseek(fd, size, SEEK_SET);
3244         if (!SetEndOfFile((HANDLE)_get_osfhandle(fd))) {
3245             errno = EACCES;
3246             retval = -1;
3247         }
3248     }
3249     win32_lseek(fd, cur, SEEK_SET);
3250     return retval;
3251 #else
3252     return chsize(fd, (long)size);
3253 #endif
3254 }
3255
3256 DllExport Off_t
3257 win32_lseek(int fd, Off_t offset, int origin)
3258 {
3259 #if defined(WIN64) || defined(USE_LARGE_FILES)
3260     return _lseeki64(fd, offset, origin);
3261 #else
3262     return lseek(fd, (long)offset, origin);
3263 #endif
3264 }
3265
3266 DllExport Off_t
3267 win32_tell(int fd)
3268 {
3269 #if defined(WIN64) || defined(USE_LARGE_FILES)
3270     return _telli64(fd);
3271 #else
3272     return tell(fd);
3273 #endif
3274 }
3275
3276 DllExport int
3277 win32_open(const char *path, int flag, ...)
3278 {
3279     dTHXa(NULL);
3280     va_list ap;
3281     int pmode;
3282
3283     va_start(ap, flag);
3284     pmode = va_arg(ap, int);
3285     va_end(ap);
3286
3287     if (stricmp(path, "/dev/null")==0)
3288         path = "NUL";
3289
3290     aTHXa(PERL_GET_THX);
3291     return open(PerlDir_mapA(path), flag, pmode);
3292 }
3293
3294 /* close() that understands socket */
3295 extern int my_close(int);       /* in win32sck.c */
3296
3297 DllExport int
3298 win32_close(int fd)
3299 {
3300 #ifdef WIN32_NO_SOCKETS
3301     return close(fd);
3302 #else
3303     return my_close(fd);
3304 #endif
3305 }
3306
3307 DllExport int
3308 win32_eof(int fd)
3309 {
3310     return eof(fd);
3311 }
3312
3313 DllExport int
3314 win32_isatty(int fd)
3315 {
3316     /* The Microsoft isatty() function returns true for *all*
3317      * character mode devices, including "nul".  Our implementation
3318      * should only return true if the handle has a console buffer.
3319      */
3320     DWORD mode;
3321     HANDLE fh = (HANDLE)_get_osfhandle(fd);
3322     if (fh == (HANDLE)-1) {
3323         /* errno is already set to EBADF */
3324         return 0;
3325     }
3326
3327     if (GetConsoleMode(fh, &mode))
3328         return 1;
3329
3330     errno = ENOTTY;
3331     return 0;
3332 }
3333
3334 DllExport int
3335 win32_dup(int fd)
3336 {
3337     return dup(fd);
3338 }
3339
3340 DllExport int
3341 win32_dup2(int fd1,int fd2)
3342 {
3343     return dup2(fd1,fd2);
3344 }
3345
3346 DllExport int
3347 win32_read(int fd, void *buf, unsigned int cnt)
3348 {
3349     return read(fd, buf, cnt);
3350 }
3351
3352 DllExport int
3353 win32_write(int fd, const void *buf, unsigned int cnt)
3354 {
3355     return write(fd, buf, cnt);
3356 }
3357
3358 DllExport int
3359 win32_mkdir(const char *dir, int mode)
3360 {
3361     dTHX;
3362     return mkdir(PerlDir_mapA(dir)); /* just ignore mode */
3363 }
3364
3365 DllExport int
3366 win32_rmdir(const char *dir)
3367 {
3368     dTHX;
3369     return rmdir(PerlDir_mapA(dir));
3370 }
3371
3372 DllExport int
3373 win32_chdir(const char *dir)
3374 {
3375     if (!dir) {
3376         errno = ENOENT;
3377         return -1;
3378     }
3379     return chdir(dir);
3380 }
3381
3382 DllExport  int
3383 win32_access(const char *path, int mode)
3384 {
3385     dTHX;
3386     return access(PerlDir_mapA(path), mode);
3387 }
3388
3389 DllExport  int
3390 win32_chmod(const char *path, int mode)
3391 {
3392     dTHX;
3393     return chmod(PerlDir_mapA(path), mode);
3394 }
3395
3396
3397 static char *
3398 create_command_line(char *cname, STRLEN clen, const char * const *args)
3399 {
3400     PERL_DEB(dTHX;)
3401     int index, argc;
3402     char *cmd, *ptr;
3403     const char *arg;
3404     STRLEN len = 0;
3405     bool bat_file = FALSE;
3406     bool cmd_shell = FALSE;
3407     bool dumb_shell = FALSE;
3408     bool extra_quotes = FALSE;
3409     bool quote_next = FALSE;
3410
3411     if (!cname)
3412         cname = (char*)args[0];
3413
3414     /* The NT cmd.exe shell has the following peculiarity that needs to be
3415      * worked around.  It strips a leading and trailing dquote when any
3416      * of the following is true:
3417      *    1. the /S switch was used
3418      *    2. there are more than two dquotes
3419      *    3. there is a special character from this set: &<>()@^|
3420      *    4. no whitespace characters within the two dquotes
3421      *    5. string between two dquotes isn't an executable file
3422      * To work around this, we always add a leading and trailing dquote
3423      * to the string, if the first argument is either "cmd.exe" or "cmd",
3424      * and there were at least two or more arguments passed to cmd.exe
3425      * (not including switches).
3426      * XXX the above rules (from "cmd /?") don't seem to be applied
3427      * always, making for the convolutions below :-(
3428      */
3429     if (cname) {
3430         if (!clen)
3431             clen = strlen(cname);
3432
3433         if (clen > 4
3434             && (stricmp(&cname[clen-4], ".bat") == 0
3435                 || (stricmp(&cname[clen-4], ".cmd") == 0)))
3436         {
3437             bat_file = TRUE;
3438             len += 3;
3439         }
3440         else {
3441             char *exe = strrchr(cname, '/');
3442             char *exe2 = strrchr(cname, '\\');
3443             if (exe2 > exe)
3444                 exe = exe2;
3445             if (exe)
3446                 ++exe;
3447             else
3448                 exe = cname;
3449             if (stricmp(exe, "cmd.exe") == 0 || stricmp(exe, "cmd") == 0) {
3450                 cmd_shell = TRUE;
3451                 len += 3;
3452             }
3453             else if (stricmp(exe, "command.com") == 0
3454                      || stricmp(exe, "command") == 0)
3455             {
3456                 dumb_shell = TRUE;
3457             }
3458         }
3459     }
3460
3461     DEBUG_p(PerlIO_printf(Perl_debug_log, "Args "));
3462     for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3463         STRLEN curlen = strlen(arg);
3464         if (!(arg[0] == '"' && arg[curlen-1] == '"'))
3465             len += 2;   /* assume quoting needed (worst case) */
3466         len += curlen + 1;
3467         DEBUG_p(PerlIO_printf(Perl_debug_log, "[%s]",arg));
3468     }
3469     DEBUG_p(PerlIO_printf(Perl_debug_log, "\n"));
3470
3471     argc = index;
3472     Newx(cmd, len, char);
3473     ptr = cmd;
3474
3475     if (bat_file) {
3476         *ptr++ = '"';
3477         extra_quotes = TRUE;
3478     }
3479
3480     for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3481         bool do_quote = 0;
3482         STRLEN curlen = strlen(arg);
3483
3484         /* we want to protect empty arguments and ones with spaces with
3485          * dquotes, but only if they aren't already there */
3486         if (!dumb_shell) {
3487             if (!curlen) {
3488                 do_quote = 1;
3489             }
3490             else if (quote_next) {
3491                 /* see if it really is multiple arguments pretending to
3492                  * be one and force a set of quotes around it */
3493                 if (*find_next_space(arg))
3494                     do_quote = 1;
3495             }
3496             else if (!(arg[0] == '"' && curlen > 1 && arg[curlen-1] == '"')) {
3497                 STRLEN i = 0;
3498                 while (i < curlen) {
3499                     if (isSPACE(arg[i])) {
3500                         do_quote = 1;
3501                     }
3502                     else if (arg[i] == '"') {
3503                         do_quote = 0;
3504                         break;
3505                     }
3506                     i++;
3507                 }
3508             }
3509         }
3510
3511         if (do_quote)
3512             *ptr++ = '"';
3513
3514         strcpy(ptr, arg);
3515         ptr += curlen;
3516
3517         if (do_quote)
3518             *ptr++ = '"';
3519
3520         if (args[index+1])
3521             *ptr++ = ' ';
3522
3523         if (!extra_quotes
3524             && cmd_shell
3525             && curlen >= 2
3526             && *arg  == '/'     /* see if arg is "/c", "/x/c", "/x/d/c" etc. */
3527             && stricmp(arg+curlen-2, "/c") == 0)
3528         {
3529             /* is there a next argument? */
3530             if (args[index+1]) {
3531                 /* are there two or more next arguments? */
3532                 if (args[index+2]) {
3533                     *ptr++ = '"';
3534                     extra_quotes = TRUE;
3535                 }
3536                 else {
3537                     /* single argument, force quoting if it has spaces */
3538                     quote_next = TRUE;
3539                 }
3540             }
3541         }
3542     }
3543
3544     if (extra_quotes)
3545         *ptr++ = '"';
3546
3547     *ptr = '\0';
3548
3549     return cmd;
3550 }
3551
3552 static const char *exe_extensions[] =
3553   {
3554     ".exe", /* this must be first */
3555     ".cmd",
3556     ".bat"
3557   };
3558
3559 static char *
3560 qualified_path(const char *cmd, bool other_exts)
3561 {
3562     char *pathstr;
3563     char *fullcmd, *curfullcmd;
3564     STRLEN cmdlen = 0;
3565     int has_slash = 0;
3566
3567     if (!cmd)
3568         return NULL;
3569     fullcmd = (char*)cmd;
3570     while (*fullcmd) {
3571         if (*fullcmd == '/' || *fullcmd == '\\')
3572             has_slash++;
3573         fullcmd++;
3574         cmdlen++;
3575     }
3576
3577     /* look in PATH */
3578     {
3579         dTHX;
3580         pathstr = PerlEnv_getenv("PATH");
3581     }
3582     /* worst case: PATH is a single directory; we need additional space
3583      * to append "/", ".exe" and trailing "\0" */
3584     Newx(fullcmd, (pathstr ? strlen(pathstr) : 0) + cmdlen + 6, char);
3585     curfullcmd = fullcmd;
3586
3587     while (1) {
3588         DWORD res;
3589
3590         /* start by appending the name to the current prefix */
3591         strcpy(curfullcmd, cmd);
3592         curfullcmd += cmdlen;
3593
3594         /* if it doesn't end with '.', or has no extension, try adding
3595          * a trailing .exe first */
3596         if (cmd[cmdlen-1] != '.'
3597             && (cmdlen < 4 || cmd[cmdlen-4] != '.'))
3598         {
3599             int i;
3600             /* first extension is .exe */
3601             int ext_limit = other_exts ? C_ARRAY_LENGTH(exe_extensions) : 1;
3602             for (i = 0; i < ext_limit; ++i) {
3603                 strcpy(curfullcmd, exe_extensions[i]);
3604                 res = GetFileAttributes(fullcmd);
3605                 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3606                     return fullcmd;
3607             }
3608
3609             *curfullcmd = '\0';
3610         }
3611
3612         /* that failed, try the bare name */
3613         res = GetFileAttributes(fullcmd);
3614         if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3615             return fullcmd;
3616
3617         /* quit if no other path exists, or if cmd already has path */
3618         if (!pathstr || !*pathstr || has_slash)
3619             break;
3620
3621         /* skip leading semis */
3622         while (*pathstr == ';')
3623             pathstr++;
3624
3625         /* build a new prefix from scratch */
3626         curfullcmd = fullcmd;
3627         while (*pathstr && *pathstr != ';') {
3628             if (*pathstr == '"') {      /* foo;"baz;etc";bar */
3629                 pathstr++;              /* skip initial '"' */
3630                 while (*pathstr && *pathstr != '"') {
3631                     *curfullcmd++ = *pathstr++;
3632                 }
3633                 if (*pathstr)
3634                     pathstr++;          /* skip trailing '"' */
3635             }
3636             else {
3637                 *curfullcmd++ = *pathstr++;
3638             }
3639         }
3640         if (*pathstr)
3641             pathstr++;                  /* skip trailing semi */
3642         if (curfullcmd > fullcmd        /* append a dir separator */
3643             && curfullcmd[-1] != '/' && curfullcmd[-1] != '\\')
3644         {
3645             *curfullcmd++ = '\\';
3646         }
3647     }
3648
3649     Safefree(fullcmd);
3650     return NULL;
3651 }
3652
3653 /* The following are just place holders.
3654  * Some hosts may provide and environment that the OS is
3655  * not tracking, therefore, these host must provide that
3656  * environment and the current directory to CreateProcess
3657  */
3658
3659 DllExport void*
3660 win32_get_childenv(void)
3661 {
3662     return NULL;
3663 }
3664
3665 DllExport void
3666 win32_free_childenv(void* d)
3667 {
3668 }
3669
3670 DllExport void
3671 win32_clearenv(void)
3672 {
3673     char *envv = GetEnvironmentStrings();
3674     char *cur = envv;
3675     STRLEN len;
3676     while (*cur) {
3677         char *end = strchr(cur,'=');
3678         if (end && end != cur) {
3679             *end = '\0';
3680             SetEnvironmentVariable(cur, NULL);
3681             *end = '=';
3682             cur = end + strlen(end+1)+2;
3683         }
3684         else if ((len = strlen(cur)))
3685             cur += len+1;
3686     }
3687     FreeEnvironmentStrings(envv);
3688 }
3689
3690 DllExport char*
3691 win32_get_childdir(void)
3692 {
3693     char* ptr;
3694     char szfilename[MAX_PATH+1];
3695
3696     GetCurrentDirectoryA(MAX_PATH+1, szfilename);
3697     Newx(ptr, strlen(szfilename)+1, char);
3698     strcpy(ptr, szfilename);
3699     return ptr;
3700 }
3701
3702 DllExport void
3703 win32_free_childdir(char* d)
3704 {
3705     Safefree(d);
3706 }
3707
3708
3709 /* XXX this needs to be made more compatible with the spawnvp()
3710  * provided by the various RTLs.  In particular, searching for
3711  * *.{com,bat,cmd} files (as done by the RTLs) is unimplemented.
3712  * This doesn't significantly affect perl itself, because we
3713  * always invoke things using PERL5SHELL if a direct attempt to
3714  * spawn the executable fails.
3715  *
3716  * XXX splitting and rejoining the commandline between do_aspawn()
3717  * and win32_spawnvp() could also be avoided.
3718  */
3719
3720 DllExport int
3721 win32_spawnvp(int mode, const char *cmdname, const char *const *argv)
3722 {
3723 #ifdef USE_RTL_SPAWNVP
3724     return _spawnvp(mode, cmdname, (char * const *)argv);
3725 #else
3726     return do_spawnvp_handles(mode, cmdname, argv, NULL);
3727 #endif
3728 }
3729
3730 static int
3731 do_spawnvp_handles(int mode, const char *cmdname, const char *const *argv,
3732                 const int *handles) {
3733     dTHXa(NULL);
3734     int ret;
3735     void* env;
3736     char* dir;
3737     child_IO_table tbl;
3738     STARTUPINFO StartupInfo;
3739     PROCESS_INFORMATION ProcessInformation;
3740     DWORD create = 0;
3741     char *cmd;
3742     char *fullcmd = NULL;
3743     char *cname = (char *)cmdname;
3744     STRLEN clen = 0;
3745
3746     if (cname) {
3747         clen = strlen(cname);
3748         /* if command name contains dquotes, must remove them */
3749         if (strchr(cname, '"')) {
3750             cmd = cname;
3751             Newx(cname,clen+1,char);
3752             clen = 0;
3753             while (*cmd) {
3754                 if (*cmd != '"') {
3755                     cname[clen] = *cmd;
3756                     ++clen;
3757                 }
3758                 ++cmd;
3759             }
3760             cname[clen] = '\0';
3761         }
3762     }
3763
3764     cmd = create_command_line(cname, clen, argv);
3765
3766     aTHXa(PERL_GET_THX);
3767     env = PerlEnv_get_childenv();
3768     dir = PerlEnv_get_childdir();
3769
3770     switch(mode) {
3771     case P_NOWAIT:      /* asynch + remember result */
3772         if (w32_num_children >= MAXIMUM_WAIT_OBJECTS) {
3773             errno = EAGAIN;
3774             ret = -1;
3775             goto RETVAL;
3776         }
3777         /* Create a new process group so we can use GenerateConsoleCtrlEvent()
3778          * in win32_kill()
3779          */
3780         create |= CREATE_NEW_PROCESS_GROUP;
3781         /* FALL THROUGH */
3782
3783     case P_WAIT:        /* synchronous execution */
3784         break;
3785     default:            /* invalid mode */
3786         errno = EINVAL;
3787         ret = -1;
3788         goto RETVAL;
3789     }
3790
3791     memset(&StartupInfo,0,sizeof(StartupInfo));
3792     StartupInfo.cb = sizeof(StartupInfo);
3793     memset(&tbl,0,sizeof(tbl));
3794     PerlEnv_get_child_IO(&tbl);
3795     StartupInfo.dwFlags         = tbl.dwFlags;
3796     StartupInfo.dwX             = tbl.dwX;
3797     StartupInfo.dwY             = tbl.dwY;
3798     StartupInfo.dwXSize         = tbl.dwXSize;
3799     StartupInfo.dwYSize         = tbl.dwYSize;
3800     StartupInfo.dwXCountChars   = tbl.dwXCountChars;
3801     StartupInfo.dwYCountChars   = tbl.dwYCountChars;
3802     StartupInfo.dwFillAttribute = tbl.dwFillAttribute;
3803     StartupInfo.wShowWindow     = tbl.wShowWindow;
3804     StartupInfo.hStdInput       = handles && handles[0] != -1 ?
3805             (HANDLE)_get_osfhandle(handles[0]) : tbl.childStdIn;
3806     StartupInfo.hStdOutput      = handles && handles[1] != -1 ?
3807             (HANDLE)_get_osfhandle(handles[1]) : tbl.childStdOut;
3808     StartupInfo.hStdError       = handles && handles[2] != -1 ?
3809             (HANDLE)_get_osfhandle(handles[2]) : tbl.childStdErr;
3810     if (StartupInfo.hStdInput == INVALID_HANDLE_VALUE &&
3811         StartupInfo.hStdOutput == INVALID_HANDLE_VALUE &&
3812         StartupInfo.hStdError == INVALID_HANDLE_VALUE)
3813     {
3814         create |= CREATE_NEW_CONSOLE;
3815     }
3816     else {
3817         StartupInfo.dwFlags |= STARTF_USESTDHANDLES;
3818     }
3819     if (w32_use_showwindow) {
3820         StartupInfo.dwFlags |= STARTF_USESHOWWINDOW;
3821         StartupInfo.wShowWindow = w32_showwindow;
3822     }
3823
3824     DEBUG_p(PerlIO_printf(Perl_debug_log, "Spawning [%s] with [%s]\n",
3825                           cname,cmd));
3826 RETRY:
3827     if (!CreateProcess(cname,           /* search PATH to find executable */
3828                        cmd,             /* executable, and its arguments */
3829                        NULL,            /* process attributes */
3830                        NULL,            /* thread attributes */
3831                        TRUE,            /* inherit handles */
3832                        create,          /* creation flags */
3833                        (LPVOID)env,     /* inherit environment */
3834                        dir,             /* inherit cwd */
3835                        &StartupInfo,
3836                        &ProcessInformation))
3837     {
3838         /* initial NULL argument to CreateProcess() does a PATH
3839          * search, but it always first looks in the directory
3840          * where the current process was started, which behavior
3841          * is undesirable for backward compatibility.  So we
3842          * jump through our own hoops by picking out the path
3843          * we really want it to use. */
3844         if (!fullcmd) {
3845             fullcmd = qualified_path(cname, FALSE);
3846             if (fullcmd) {
3847                 if (cname != cmdname)
3848                     Safefree(cname);
3849                 cname = fullcmd;
3850                 DEBUG_p(PerlIO_printf(Perl_debug_log,
3851                                       "Retrying [%s] with same args\n",
3852                                       cname));
3853                 goto RETRY;
3854             }
3855         }
3856         errno = ENOENT;
3857         ret = -1;
3858         goto RETVAL;
3859     }
3860
3861     if (mode == P_NOWAIT) {
3862         /* asynchronous spawn -- store handle, return PID */
3863         ret = (int)ProcessInformation.dwProcessId;
3864
3865         w32_child_handles[w32_num_children] = ProcessInformation.hProcess;
3866         w32_child_pids[w32_num_children] = (DWORD)ret;
3867         ++w32_num_children;
3868     }
3869     else  {
3870         DWORD status;
3871         win32_msgwait(aTHX_ 1, &ProcessInformation.hProcess, INFINITE, NULL);
3872         /* FIXME: if msgwait returned due to message perhaps forward the
3873            "signal" to the process
3874          */
3875         GetExitCodeProcess(ProcessInformation.hProcess, &status);
3876         ret = (int)status;
3877         CloseHandle(ProcessInformation.hProcess);
3878     }
3879
3880     CloseHandle(ProcessInformation.hThread);
3881
3882 RETVAL:
3883     PerlEnv_free_childenv(env);
3884     PerlEnv_free_childdir(dir);
3885     Safefree(cmd);
3886     if (cname != cmdname)
3887         Safefree(cname);
3888     return ret;
3889 }
3890
3891 DllExport int
3892 win32_execv(const char *cmdname, const char *const *argv)
3893 {
3894 #ifdef USE_ITHREADS
3895     dTHX;
3896     /* if this is a pseudo-forked child, we just want to spawn
3897      * the new program, and return */
3898     if (w32_pseudo_id)
3899         return _spawnv(P_WAIT, cmdname, argv);
3900 #endif
3901     return _execv(cmdname, argv);
3902 }
3903
3904 DllExport int
3905 win32_execvp(const char *cmdname, const char *const *argv)
3906 {
3907 #ifdef USE_ITHREADS
3908     dTHX;
3909     /* if this is a pseudo-forked child, we just want to spawn
3910      * the new program, and return */
3911     if (w32_pseudo_id) {
3912         int status = win32_spawnvp(P_WAIT, cmdname, (const char *const *)argv);
3913         if (status != -1) {
3914             my_exit(status);
3915             return 0;
3916         }
3917         else
3918             return status;
3919     }
3920 #endif
3921     return _execvp(cmdname, argv);
3922 }
3923
3924 DllExport void
3925 win32_perror(const char *str)
3926 {
3927     perror(str);
3928 }
3929
3930 DllExport void
3931 win32_setbuf(FILE *pf, char *buf)
3932 {
3933     setbuf(pf, buf);
3934 }
3935
3936 DllExport int
3937 win32_setvbuf(FILE *pf, char *buf, int type, size_t size)
3938 {
3939     return setvbuf(pf, buf, type, size);
3940 }
3941
3942 DllExport int
3943 win32_flushall(void)
3944 {
3945     return flushall();
3946 }
3947
3948 DllExport int
3949 win32_fcloseall(void)
3950 {
3951     return fcloseall();
3952 }
3953
3954 DllExport char*
3955 win32_fgets(char *s, int n, FILE *pf)
3956 {
3957     return fgets(s, n, pf);
3958 }
3959
3960 DllExport char*
3961 win32_gets(char *s)
3962 {
3963     return gets(s);
3964 }
3965
3966 DllExport int
3967 win32_fgetc(FILE *pf)
3968 {
3969     return fgetc(pf);
3970 }
3971
3972 DllExport int
3973 win32_putc(int c, FILE *pf)
3974 {
3975     return putc(c,pf);
3976 }
3977
3978 DllExport int
3979 win32_puts(const char *s)
3980 {
3981     return puts(s);
3982 }
3983
3984 DllExport int
3985 win32_getchar(void)
3986 {
3987     return getchar();
3988 }
3989
3990 DllExport int
3991 win32_putchar(int c)
3992 {
3993     return putchar(c);
3994 }
3995
3996 #ifdef MYMALLOC
3997
3998 #ifndef USE_PERL_SBRK
3999
4000 static char *committed = NULL;          /* XXX threadead */
4001 static char *base      = NULL;          /* XXX threadead */
4002 static char *reserved  = NULL;          /* XXX threadead */
4003 static char *brk       = NULL;          /* XXX threadead */
4004 static DWORD pagesize  = 0;             /* XXX threadead */
4005
4006 void *
4007 sbrk(ptrdiff_t need)
4008 {
4009  void *result;
4010  if (!pagesize)
4011   {SYSTEM_INFO info;
4012    GetSystemInfo(&info);
4013    /* Pretend page size is larger so we don't perpetually
4014     * call the OS to commit just one page ...
4015     */
4016    pagesize = info.dwPageSize << 3;
4017   }
4018  if (brk+need >= reserved)
4019   {
4020    DWORD size = brk+need-reserved;
4021    char *addr;
4022    char *prev_committed = NULL;
4023    if (committed && reserved && committed < reserved)
4024     {
4025      /* Commit last of previous chunk cannot span allocations */
4026      addr = (char *) VirtualAlloc(committed,reserved-committed,MEM_COMMIT,PAGE_READWRITE);
4027      if (addr)
4028       {
4029       /* Remember where we committed from in case we want to decommit later */
4030       prev_committed = committed;
4031       committed = reserved;
4032       }
4033     }
4034    /* Reserve some (more) space
4035     * Contiguous blocks give us greater efficiency, so reserve big blocks -
4036     * this is only address space not memory...
4037     * Note this is a little sneaky, 1st call passes NULL as reserved
4038     * so lets system choose where we start, subsequent calls pass
4039     * the old end address so ask for a contiguous block
4040     */
4041 sbrk_reserve:
4042    if (size < 64*1024*1024)
4043     size = 64*1024*1024;
4044    size = ((size + pagesize - 1) / pagesize) * pagesize;
4045    addr  = (char *) VirtualAlloc(reserved,size,MEM_RESERVE,PAGE_NOACCESS);
4046    if (addr)
4047     {
4048      reserved = addr+size;
4049      if (!base)
4050       base = addr;
4051      if (!committed)
4052       committed = base;
4053      if (!brk)
4054       brk = committed;
4055     }
4056    else if (reserved)
4057     {
4058       /* The existing block could not be extended far enough, so decommit
4059        * anything that was just committed above and start anew */
4060       if (prev_committed)
4061        {
4062        if (!VirtualFree(prev_committed,reserved-prev_committed,MEM_DECOMMIT))
4063         return (void *) -1;
4064        }
4065       reserved = base = committed = brk = NULL;
4066       size = need;
4067       goto sbrk_reserve;
4068     }
4069    else
4070     {
4071      return (void *) -1;
4072     }
4073   }
4074  result = brk;
4075  brk += need;
4076  if (brk > committed)
4077   {
4078    DWORD size = ((brk-committed + pagesize -1)/pagesize) * pagesize;
4079    char *addr;
4080    if (committed+size > reserved)
4081     size = reserved-committed;
4082    addr = (char *) VirtualAlloc(committed,size,MEM_COMMIT,PAGE_READWRITE);
4083    if (addr)
4084     committed += size;
4085    else
4086     return (void *) -1;
4087   }
4088  return result;
4089 }
4090
4091 #endif
4092 #endif
4093
4094 DllExport void*
4095 win32_malloc(size_t size)
4096 {
4097     return malloc(size);
4098 }
4099
4100 DllExport void*
4101 win32_calloc(size_t numitems, size_t size)
4102 {
4103     return calloc(numitems,size);
4104 }
4105
4106 DllExport void*
4107 win32_realloc(void *block, size_t size)
4108 {
4109     return realloc(block,size);
4110 }
4111
4112 DllExport void
4113 win32_free(void *block)
4114 {
4115     free(block);
4116 }
4117
4118
4119 DllExport int
4120 win32_open_osfhandle(intptr_t handle, int flags)
4121 {
4122     return _open_osfhandle(handle, flags);
4123 }
4124
4125 DllExport intptr_t
4126 win32_get_osfhandle(int fd)
4127 {
4128     return (intptr_t)_get_osfhandle(fd);
4129 }
4130
4131 DllExport FILE *
4132 win32_fdupopen(FILE *pf)
4133 {
4134     FILE* pfdup;
4135     fpos_t pos;
4136     char mode[3];
4137     int fileno = win32_dup(win32_fileno(pf));
4138
4139     /* open the file in the same mode */
4140     if((pf)->_flag & _IOREAD) {
4141         mode[0] = 'r';
4142         mode[1] = 0;
4143     }
4144     else if((pf)->_flag & _IOWRT) {
4145         mode[0] = 'a';
4146         mode[1] = 0;
4147     }
4148     else if((pf)->_flag & _IORW) {
4149         mode[0] = 'r';
4150         mode[1] = '+';
4151         mode[2] = 0;
4152     }
4153
4154     /* it appears that the binmode is attached to the
4155      * file descriptor so binmode files will be handled
4156      * correctly
4157      */
4158     pfdup = win32_fdopen(fileno, mode);
4159
4160     /* move the file pointer to the same position */
4161     if (!fgetpos(pf, &pos)) {
4162         fsetpos(pfdup, &pos);
4163     }
4164     return pfdup;
4165 }
4166
4167 DllExport void*
4168 win32_dynaload(const char* filename)
4169 {
4170     dTHXa(NULL);
4171     char buf[MAX_PATH+1];
4172     const char *first;
4173
4174     /* LoadLibrary() doesn't recognize forward slashes correctly,
4175      * so turn 'em back. */
4176     first = strchr(filename, '/');
4177     if (first) {
4178         STRLEN len = strlen(filename);
4179         if (len <= MAX_PATH) {
4180             strcpy(buf, filename);
4181             filename = &buf[first - filename];
4182             while (*filename) {
4183                 if (*filename == '/')
4184                     *(char*)filename = '\\';
4185                 ++filename;
4186             }
4187             filename = buf;
4188         }
4189     }
4190     aTHXa(PERL_GET_THX);
4191     return LoadLibraryExA(PerlDir_mapA(filename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
4192 }
4193
4194 XS(w32_SetChildShowWindow)
4195 {
4196     dXSARGS;
4197     BOOL use_showwindow = w32_use_showwindow;
4198     /* use "unsigned short" because Perl has redefined "WORD" */
4199     unsigned short showwindow = w32_showwindow;
4200
4201     if (items > 1)
4202         croak_xs_usage(cv, "[showwindow]");
4203
4204     if (items == 0 || !SvOK(ST(0)))
4205         w32_use_showwindow = FALSE;
4206     else {
4207         w32_use_showwindow = TRUE;
4208         w32_showwindow = (unsigned short)SvIV(ST(0));
4209     }
4210
4211     EXTEND(SP, 1);
4212     if (use_showwindow)
4213         ST(0) = sv_2mortal(newSViv(showwindow));
4214     else
4215         ST(0) = &PL_sv_undef;
4216     XSRETURN(1);
4217 }
4218
4219 void
4220 Perl_init_os_extras(void)
4221 {
4222     dTHXa(NULL);
4223     char *file = __FILE__;
4224
4225     /* Initialize Win32CORE if it has been statically linked. */
4226 #ifndef PERL_IS_MINIPERL
4227     void (*pfn_init)(pTHX);
4228     HMODULE module = (HMODULE)((w32_perldll_handle == INVALID_HANDLE_VALUE)
4229                                ? GetModuleHandle(NULL)
4230                                : w32_perldll_handle);
4231     pfn_init = (void (*)(pTHX))GetProcAddress(module, "init_Win32CORE");
4232     aTHXa(PERL_GET_THX);
4233     if (pfn_init)
4234         pfn_init(aTHX);
4235 #else
4236     aTHXa(PERL_GET_THX);
4237 #endif
4238
4239     newXS("Win32::SetChildShowWindow", w32_SetChildShowWindow, file);
4240 }
4241
4242 void *
4243 win32_signal_context(void)
4244 {
4245     dTHX;
4246 #ifdef MULTIPLICITY
4247     if (!my_perl) {
4248         my_perl = PL_curinterp;
4249         PERL_SET_THX(my_perl);
4250     }
4251     return my_perl;
4252 #else
4253     return PL_curinterp;
4254 #endif
4255 }
4256
4257
4258 BOOL WINAPI
4259 win32_ctrlhandler(DWORD dwCtrlType)
4260 {
4261 #ifdef MULTIPLICITY
4262     dTHXa(PERL_GET_SIG_CONTEXT);
4263
4264     if (!my_perl)
4265         return FALSE;
4266 #endif
4267
4268     switch(dwCtrlType) {
4269     case CTRL_CLOSE_EVENT:
4270      /*  A signal that the system sends to all processes attached to a console when
4271          the user closes the console (either by choosing the Close command from the
4272          console window's System menu, or by choosing the End Task command from the
4273          Task List
4274       */
4275         if (do_raise(aTHX_ 1))        /* SIGHUP */
4276             sig_terminate(aTHX_ 1);
4277         return TRUE;
4278
4279     case CTRL_C_EVENT:
4280         /*  A CTRL+c signal was received */
4281         if (do_raise(aTHX_ SIGINT))
4282             sig_terminate(aTHX_ SIGINT);
4283         return TRUE;
4284
4285     case CTRL_BREAK_EVENT:
4286         /*  A CTRL+BREAK signal was received */
4287         if (do_raise(aTHX_ SIGBREAK))
4288             sig_terminate(aTHX_ SIGBREAK);
4289         return TRUE;
4290
4291     case CTRL_LOGOFF_EVENT:
4292       /*  A signal that the system sends to all console processes when a user is logging
4293           off. This signal does not indicate which user is logging off, so no
4294           assumptions can be made.
4295        */
4296         break;
4297     case CTRL_SHUTDOWN_EVENT:
4298       /*  A signal that the system sends to all console processes when the system is
4299           shutting down.
4300        */
4301         if (do_raise(aTHX_ SIGTERM))
4302             sig_terminate(aTHX_ SIGTERM);
4303         return TRUE;
4304     default:
4305         break;
4306     }
4307     return FALSE;
4308 }
4309
4310
4311 #ifdef SET_INVALID_PARAMETER_HANDLER
4312 #  include <crtdbg.h>
4313 #endif
4314
4315 static void
4316 ansify_path(void)
4317 {
4318     size_t len;
4319     char *ansi_path;
4320     WCHAR *wide_path;
4321     WCHAR *wide_dir;
4322
4323     /* fetch Unicode version of PATH */
4324     len = 2000;
4325     wide_path = (WCHAR*)win32_malloc(len*sizeof(WCHAR));
4326     while (wide_path) {
4327         size_t newlen = GetEnvironmentVariableW(L"PATH", wide_path, len);
4328         if (newlen == 0) {
4329             win32_free(wide_path);
4330             return;
4331         }
4332         if (newlen < len)
4333             break;
4334         len = newlen;
4335         wide_path = (WCHAR*)win32_realloc(wide_path, len*sizeof(WCHAR));
4336     }
4337     if (!wide_path)
4338         return;
4339
4340     /* convert to ANSI pathnames */
4341     wide_dir = wide_path;
4342     ansi_path = NULL;
4343     while (wide_dir) {
4344         WCHAR *sep = wcschr(wide_dir, ';');
4345         char *ansi_dir;
4346         size_t ansi_len;
4347         size_t wide_len;
4348
4349         if (sep)
4350             *sep++ = '\0';
4351
4352         /* remove quotes around pathname */
4353         if (*wide_dir == '"')
4354             ++wide_dir;
4355         wide_len = wcslen(wide_dir);
4356         if (wide_len && wide_dir[wide_len-1] == '"')
4357             wide_dir[wide_len-1] = '\0';
4358
4359         /* append ansi_dir to ansi_path */
4360         ansi_dir = win32_ansipath(wide_dir);
4361         ansi_len = strlen(ansi_dir);
4362         if (ansi_path) {
4363             size_t newlen = len + 1 + ansi_len;
4364             ansi_path = (char*)win32_realloc(ansi_path, newlen+1);
4365             if (!ansi_path)
4366                 break;
4367             ansi_path[len] = ';';
4368             memcpy(ansi_path+len+1, ansi_dir, ansi_len+1);
4369             len = newlen;
4370         }
4371         else {
4372             len = ansi_len;
4373             ansi_path = (char*)win32_malloc(5+len+1);
4374             if (!ansi_path)
4375                 break;
4376             memcpy(ansi_path, "PATH=", 5);
4377             memcpy(ansi_path+5, ansi_dir, len+1);
4378             len += 5;
4379         }
4380         win32_free(ansi_dir);
4381         wide_dir = sep;
4382     }
4383
4384     if (ansi_path) {
4385         /* Update C RTL environ array.  This will only have full effect if
4386          * perl_parse() is later called with `environ` as the `env` argument.
4387          * Otherwise S_init_postdump_symbols() will overwrite PATH again.
4388          *
4389          * We do have to ansify() the PATH before Perl has been fully
4390          * initialized because S_find_script() uses the PATH when perl
4391          * is being invoked with the -S option.  This happens before %ENV
4392          * is initialized in S_init_postdump_symbols().
4393          *
4394          * XXX Is this a bug? Should S_find_script() use the environment
4395          * XXX passed in the `env` arg to parse_perl()?
4396          */
4397         putenv(ansi_path);
4398         /* Keep system environment in sync because S_init_postdump_symbols()
4399          * will not call mg_set() if it initializes %ENV from `environ`.
4400          */
4401         SetEnvironmentVariableA("PATH", ansi_path+5);
4402         win32_free(ansi_path);
4403     }
4404     win32_free(wide_path);
4405 }
4406
4407 void
4408 Perl_win32_init(int *argcp, char ***argvp)
4409 {
4410 #ifdef SET_INVALID_PARAMETER_HANDLER
4411     _invalid_parameter_handler oldHandler, newHandler;
4412     newHandler = my_invalid_parameter_handler;
4413     oldHandler = _set_invalid_parameter_handler(newHandler);
4414     _CrtSetReportMode(_CRT_ASSERT, 0);
4415 #endif
4416     /* Disable floating point errors, Perl will trap the ones we
4417      * care about.  VC++ RTL defaults to switching these off
4418      * already, but some RTLs don't.  Since we don't
4419      * want to be at the vendor's whim on the default, we set
4420      * it explicitly here.
4421      */
4422 #if !defined(__GNUC__)
4423     _control87(MCW_EM, MCW_EM);
4424 #endif
4425     MALLOC_INIT;
4426
4427     /* When the manifest resource requests Common-Controls v6 then
4428      * user32.dll no longer registers all the Windows classes used for
4429      * standard controls but leaves some of them to be registered by
4430      * comctl32.dll.  InitCommonControls() doesn't do anything but calling
4431      * it makes sure comctl32.dll gets loaded into the process and registers
4432      * the standard control classes.  Without this even normal Windows APIs
4433      * like MessageBox() can fail under some versions of Windows XP.
4434      */
4435     InitCommonControls();
4436
4437     g_osver.dwOSVersionInfoSize = sizeof(g_osver);
4438     GetVersionEx(&g_osver);
4439
4440 #ifdef WIN32_DYN_IOINFO_SIZE
4441     {
4442         Size_t ioinfo_size = _msize((void*)__pioinfo[0]);;
4443         if((SSize_t)ioinfo_size <= 0) { /* -1 is err */
4444             fprintf(stderr, "panic: invalid size for ioinfo\n"); /* no interp */
4445             exit(1);
4446         }
4447         ioinfo_size /= IOINFO_ARRAY_ELTS;
4448         w32_ioinfo_size = ioinfo_size;
4449     }
4450 #endif
4451
4452     ansify_path();
4453 }
4454
4455 void
4456 Perl_win32_term(void)
4457 {
4458     HINTS_REFCNT_TERM;
4459     OP_REFCNT_TERM;
4460     PERLIO_TERM;
4461     MALLOC_TERM;
4462 }
4463
4464 void
4465 win32_get_child_IO(child_IO_table* ptbl)
4466 {
4467     ptbl->childStdIn    = GetStdHandle(STD_INPUT_HANDLE);
4468     ptbl->childStdOut   = GetStdHandle(STD_OUTPUT_HANDLE);
4469     ptbl->childStdErr   = GetStdHandle(STD_ERROR_HANDLE);
4470 }
4471
4472 Sighandler_t
4473 win32_signal(int sig, Sighandler_t subcode)
4474 {
4475     dTHXa(NULL);
4476     if (sig < SIG_SIZE) {
4477         int save_errno = errno;
4478         Sighandler_t result;
4479 #ifdef SET_INVALID_PARAMETER_HANDLER
4480         /* Silence our invalid parameter handler since we expect to make some
4481          * calls with invalid signal numbers giving a SIG_ERR result. */
4482         BOOL oldvalue = set_silent_invalid_parameter_handler(TRUE);
4483 #endif
4484         result = signal(sig, subcode);
4485 #ifdef SET_INVALID_PARAMETER_HANDLER
4486         set_silent_invalid_parameter_handler(oldvalue);
4487 #endif
4488         aTHXa(PERL_GET_THX);
4489         if (result == SIG_ERR) {
4490             result = w32_sighandler[sig];
4491             errno = save_errno;
4492         }
4493         w32_sighandler[sig] = subcode;
4494         return result;
4495     }
4496     else {
4497         errno = EINVAL;
4498         return SIG_ERR;
4499     }
4500 }
4501
4502 /* The PerlMessageWindowClass's WindowProc */
4503 LRESULT CALLBACK
4504 win32_message_window_proc(HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam)
4505 {
4506     return win32_process_message(hwnd, msg, wParam, lParam) ?
4507         0 : DefWindowProc(hwnd, msg, wParam, lParam);
4508 }
4509
4510 /* The real message handler. Can be called with
4511  * hwnd == NULL to process our thread messages. Returns TRUE for any messages
4512  * that it processes */
4513 static LRESULT
4514 win32_process_message(HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam)
4515 {
4516     /* BEWARE. The context retrieved using dTHX; is the context of the
4517      * 'parent' thread during the CreateWindow() phase - i.e. for all messages
4518      * up to and including WM_CREATE.  If it ever happens that you need the
4519      * 'child' context before this, then it needs to be passed into
4520      * win32_create_message_window(), and passed to the WM_NCCREATE handler
4521      * from the lparam of CreateWindow().  It could then be stored/retrieved
4522      * using [GS]etWindowLongPtr(... GWLP_USERDATA ...), possibly eliminating
4523      * the dTHX calls here. */
4524     /* XXX For now it is assumed that the overhead of the dTHX; for what
4525      * are relativley infrequent code-paths, is better than the added
4526      * complexity of getting the correct context passed into
4527      * win32_create_message_window() */
4528     dTHX;
4529
4530     switch(msg) {
4531
4532 #ifdef USE_ITHREADS
4533         case WM_USER_MESSAGE: {
4534             long child = find_pseudo_pid(aTHX_ (int)wParam);
4535             if (child >= 0) {
4536                 w32_pseudo_child_message_hwnds[child] = (HWND)lParam;
4537                 return 1;
4538             }
4539             break;
4540         }
4541 #endif
4542
4543         case WM_USER_KILL: {
4544             /* We use WM_USER_KILL to fake kill() with other signals */
4545             int sig = (int)wParam;
4546             if (do_raise(aTHX_ sig))
4547                 sig_terminate(aTHX_ sig);
4548
4549             return 1;
4550         }
4551
4552         case WM_TIMER: {
4553             /* alarm() is a one-shot but SetTimer() repeats so kill it */
4554             if (w32_timerid && w32_timerid==(UINT)wParam) {
4555                 KillTimer(w32_message_hwnd, w32_timerid);
4556                 w32_timerid=0;
4557
4558                 /* Now fake a call to signal handler */
4559                 if (do_raise(aTHX_ 14))
4560                     sig_terminate(aTHX_ 14);
4561
4562                 return 1;
4563             }
4564             break;
4565         }
4566
4567         default:
4568             break;
4569
4570     } /* switch */
4571
4572     /* Above or other stuff may have set a signal flag, and we may not have
4573      * been called from win32_async_check() (e.g. some other GUI's message
4574      * loop.  BUT DON'T dispatch signals here: If someone has set a SIGALRM
4575      * handler that die's, and the message loop that calls here is wrapped
4576      * in an eval, then you may well end up with orphaned windows - signals
4577      * are dispatched by win32_async_check() */
4578
4579     return 0;
4580 }
4581
4582 void
4583 win32_create_message_window_class(void)
4584 {
4585     /* create the window class for "message only" windows */
4586     WNDCLASS wc;
4587
4588     Zero(&wc, 1, wc);
4589     wc.lpfnWndProc = win32_message_window_proc;
4590     wc.hInstance = (HINSTANCE)GetModuleHandle(NULL);
4591     wc.lpszClassName = "PerlMessageWindowClass";
4592
4593     /* second and subsequent calls will fail, but class
4594      * will already be registered */
4595     RegisterClass(&wc);
4596 }
4597
4598 HWND
4599 win32_create_message_window(void)
4600 {
4601     win32_create_message_window_class();
4602     return CreateWindow("PerlMessageWindowClass", "PerlMessageWindow",
4603                         0, 0, 0, 0, 0, HWND_MESSAGE, NULL, NULL, NULL);
4604 }
4605
4606 #ifdef HAVE_INTERP_INTERN
4607
4608 static void
4609 win32_csighandler(int sig)
4610 {
4611 #if 0
4612     dTHXa(PERL_GET_SIG_CONTEXT);
4613     Perl_warn(aTHX_ "Got signal %d",sig);
4614 #endif
4615     /* Does nothing */
4616 }
4617
4618 #if defined(__MINGW32__) && defined(__cplusplus)
4619 #define CAST_HWND__(x) (HWND__*)(x)
4620 #else
4621 #define CAST_HWND__(x) x
4622 #endif
4623
4624 void
4625 Perl_sys_intern_init(pTHX)
4626 {
4627     int i;
4628
4629     w32_perlshell_tokens        = NULL;
4630     w32_perlshell_vec           = (char**)NULL;
4631     w32_perlshell_items         = 0;
4632     w32_fdpid                   = newAV();
4633     Newx(w32_children, 1, child_tab);
4634     w32_num_children            = 0;
4635 #  ifdef USE_ITHREADS
4636     w32_pseudo_id               = 0;
4637     Newx(w32_pseudo_children, 1, pseudo_child_tab);
4638     w32_num_pseudo_children     = 0;
4639 #  endif
4640     w32_timerid                 = 0;
4641     w32_message_hwnd            = CAST_HWND__(INVALID_HANDLE_VALUE);
4642     w32_poll_count              = 0;
4643     for (i=0; i < SIG_SIZE; i++) {
4644         w32_sighandler[i] = SIG_DFL;
4645     }
4646 #  ifdef MULTIPLICITY
4647     if (my_perl == PL_curinterp) {
4648 #  else
4649     {
4650 #  endif
4651         /* Force C runtime signal stuff to set its console handler */
4652         signal(SIGINT,win32_csighandler);
4653         signal(SIGBREAK,win32_csighandler);
4654
4655         /* We spawn asynchronous processes with the CREATE_NEW_PROCESS_GROUP
4656          * flag.  This has the side-effect of disabling Ctrl-C events in all
4657          * processes in this group.
4658          * We re-enable Ctrl-C handling by calling SetConsoleCtrlHandler()
4659          * with a NULL handler.
4660          */
4661         SetConsoleCtrlHandler(NULL,FALSE);
4662
4663         /* Push our handler on top */
4664         SetConsoleCtrlHandler(win32_ctrlhandler,TRUE);
4665     }
4666 }
4667
4668 void
4669 Perl_sys_intern_clear(pTHX)
4670 {
4671     Safefree(w32_perlshell_tokens);
4672     Safefree(w32_perlshell_vec);
4673     /* NOTE: w32_fdpid is freed by sv_clean_all() */
4674     Safefree(w32_children);
4675     if (w32_timerid) {
4676         KillTimer(w32_message_hwnd, w32_timerid);
4677         w32_timerid = 0;
4678     }
4679     if (w32_message_hwnd != NULL && w32_message_hwnd != INVALID_HANDLE_VALUE)
4680         DestroyWindow(w32_message_hwnd);
4681 #  ifdef MULTIPLICITY
4682     if (my_perl == PL_curinterp) {
4683 #  else
4684     {
4685 #  endif
4686         SetConsoleCtrlHandler(win32_ctrlhandler,FALSE);
4687     }
4688 #  ifdef USE_ITHREADS
4689     Safefree(w32_pseudo_children);
4690 #  endif
4691 }
4692
4693 #  ifdef USE_ITHREADS
4694
4695 void
4696 Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst)
4697 {
4698     PERL_ARGS_ASSERT_SYS_INTERN_DUP;
4699
4700     dst->perlshell_tokens       = NULL;
4701     dst->perlshell_vec          = (char**)NULL;
4702     dst->perlshell_items        = 0;
4703     dst->fdpid                  = newAV();
4704     Newxz(dst->children, 1, child_tab);
4705     dst->pseudo_id              = 0;
4706     Newxz(dst->pseudo_children, 1, pseudo_child_tab);
4707     dst->timerid                = 0;
4708     dst->message_hwnd           = CAST_HWND__(INVALID_HANDLE_VALUE);
4709     dst->poll_count             = 0;
4710     Copy(src->sigtable,dst->sigtable,SIG_SIZE,Sighandler_t);
4711 }
4712 #  endif /* USE_ITHREADS */
4713 #endif /* HAVE_INTERP_INTERN */