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