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