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