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