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