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