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