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