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