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