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