This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
c69c2a7bda99d83ff04087e9c9ad1bb4ada13b95
[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                     ++count;
1352                 }
1353                 if (hwnd != INVALID_HANDLE_VALUE) {
1354                     /* We fake signals to pseudo-processes using Win32
1355                      * message queue.  In Win9X the pids are negative already. */
1356                     if ((hwnd != NULL && PostMessage(hwnd, WM_USER_KILL, sig, 0)) ||
1357                         PostThreadMessage(IsWin95() ? pid : -pid, WM_USER_KILL, sig, 0))
1358                     {
1359                         /* It might be us ... */
1360                         PERL_ASYNC_CHECK();
1361                         return 0;
1362                     }
1363                 }
1364                 break;
1365             }
1366             } /* switch */
1367         }
1368         else if (IsWin95()) {
1369             pid = -pid;
1370             goto alien_process;
1371         }
1372     }
1373     else
1374 #endif
1375     {
1376         child = find_pid(pid);
1377         if (child >= 0) {
1378             if (my_kill(pid, sig)) {
1379                 DWORD exitcode = 0;
1380                 if (GetExitCodeProcess(w32_child_handles[child], &exitcode) &&
1381                     exitcode != STILL_ACTIVE)
1382                 {
1383                     remove_dead_process(child);
1384                 }
1385                 return 0;
1386             }
1387         }
1388         else {
1389 alien_process:
1390             if (my_kill((IsWin95() ? -pid : pid), sig))
1391                 return 0;
1392         }
1393     }
1394     errno = EINVAL;
1395     return -1;
1396 }
1397
1398 DllExport int
1399 win32_stat(const char *path, Stat_t *sbuf)
1400 {
1401     dTHX;
1402     char        buffer[MAX_PATH+1];
1403     int         l = strlen(path);
1404     int         res;
1405     int         nlink = 1;
1406     BOOL        expect_dir = FALSE;
1407
1408     GV          *gv_sloppy = gv_fetchpvs("\027IN32_SLOPPY_STAT",
1409                                          GV_NOTQUAL, SVt_PV);
1410     BOOL        sloppy = gv_sloppy && SvTRUE(GvSV(gv_sloppy));
1411
1412     if (l > 1) {
1413         switch(path[l - 1]) {
1414         /* FindFirstFile() and stat() are buggy with a trailing
1415          * slashes, except for the root directory of a drive */
1416         case '\\':
1417         case '/':
1418             if (l > sizeof(buffer)) {
1419                 errno = ENAMETOOLONG;
1420                 return -1;
1421             }
1422             --l;
1423             strncpy(buffer, path, l);
1424             /* remove additional trailing slashes */
1425             while (l > 1 && (buffer[l-1] == '/' || buffer[l-1] == '\\'))
1426                 --l;
1427             /* add back slash if we otherwise end up with just a drive letter */
1428             if (l == 2 && isALPHA(buffer[0]) && buffer[1] == ':')
1429                 buffer[l++] = '\\';
1430             buffer[l] = '\0';
1431             path = buffer;
1432             expect_dir = TRUE;
1433             break;
1434
1435         /* FindFirstFile() is buggy with "x:", so add a dot :-( */
1436         case ':':
1437             if (l == 2 && isALPHA(path[0])) {
1438                 buffer[0] = path[0];
1439                 buffer[1] = ':';
1440                 buffer[2] = '.';
1441                 buffer[3] = '\0';
1442                 l = 3;
1443                 path = buffer;
1444             }
1445             break;
1446         }
1447     }
1448
1449     path = PerlDir_mapA(path);
1450     l = strlen(path);
1451
1452     if (!sloppy) {
1453         /* We must open & close the file once; otherwise file attribute changes  */
1454         /* might not yet have propagated to "other" hard links of the same file. */
1455         /* This also gives us an opportunity to determine the number of links.   */
1456         HANDLE handle = CreateFileA(path, 0, 0, NULL, OPEN_EXISTING, 0, NULL);
1457         if (handle != INVALID_HANDLE_VALUE) {
1458             BY_HANDLE_FILE_INFORMATION bhi;
1459             if (GetFileInformationByHandle(handle, &bhi))
1460                 nlink = bhi.nNumberOfLinks;
1461             CloseHandle(handle);
1462         }
1463     }
1464
1465     /* path will be mapped correctly above */
1466 #if defined(WIN64) || defined(USE_LARGE_FILES)
1467     res = _stati64(path, sbuf);
1468 #else
1469     res = stat(path, sbuf);
1470 #endif
1471     sbuf->st_nlink = nlink;
1472
1473     if (res < 0) {
1474         /* CRT is buggy on sharenames, so make sure it really isn't.
1475          * XXX using GetFileAttributesEx() will enable us to set
1476          * sbuf->st_*time (but note that's not available on the
1477          * Windows of 1995) */
1478         DWORD r = GetFileAttributesA(path);
1479         if (r != 0xffffffff && (r & FILE_ATTRIBUTE_DIRECTORY)) {
1480             /* sbuf may still contain old garbage since stat() failed */
1481             Zero(sbuf, 1, Stat_t);
1482             sbuf->st_mode = S_IFDIR | S_IREAD;
1483             errno = 0;
1484             if (!(r & FILE_ATTRIBUTE_READONLY))
1485                 sbuf->st_mode |= S_IWRITE | S_IEXEC;
1486             return 0;
1487         }
1488     }
1489     else {
1490         if (l == 3 && isALPHA(path[0]) && path[1] == ':'
1491             && (path[2] == '\\' || path[2] == '/'))
1492         {
1493             /* The drive can be inaccessible, some _stat()s are buggy */
1494             if (!GetVolumeInformationA(path,NULL,0,NULL,NULL,NULL,NULL,0)) {
1495                 errno = ENOENT;
1496                 return -1;
1497             }
1498         }
1499         if (expect_dir && !S_ISDIR(sbuf->st_mode)) {
1500             errno = ENOTDIR;
1501             return -1;
1502         }
1503 #ifdef __BORLANDC__
1504         if (S_ISDIR(sbuf->st_mode))
1505             sbuf->st_mode |= S_IWRITE | S_IEXEC;
1506         else if (S_ISREG(sbuf->st_mode)) {
1507             int perms;
1508             if (l >= 4 && path[l-4] == '.') {
1509                 const char *e = path + l - 3;
1510                 if (strnicmp(e,"exe",3)
1511                     && strnicmp(e,"bat",3)
1512                     && strnicmp(e,"com",3)
1513                     && (IsWin95() || strnicmp(e,"cmd",3)))
1514                     sbuf->st_mode &= ~S_IEXEC;
1515                 else
1516                     sbuf->st_mode |= S_IEXEC;
1517             }
1518             else
1519                 sbuf->st_mode &= ~S_IEXEC;
1520             /* Propagate permissions to _group_ and _others_ */
1521             perms = sbuf->st_mode & (S_IREAD|S_IWRITE|S_IEXEC);
1522             sbuf->st_mode |= (perms>>3) | (perms>>6);
1523         }
1524 #endif
1525     }
1526     return res;
1527 }
1528
1529 #define isSLASH(c) ((c) == '/' || (c) == '\\')
1530 #define SKIP_SLASHES(s) \
1531     STMT_START {                                \
1532         while (*(s) && isSLASH(*(s)))           \
1533             ++(s);                              \
1534     } STMT_END
1535 #define COPY_NONSLASHES(d,s) \
1536     STMT_START {                                \
1537         while (*(s) && !isSLASH(*(s)))          \
1538             *(d)++ = *(s)++;                    \
1539     } STMT_END
1540
1541 /* Find the longname of a given path.  path is destructively modified.
1542  * It should have space for at least MAX_PATH characters. */
1543 DllExport char *
1544 win32_longpath(char *path)
1545 {
1546     WIN32_FIND_DATA fdata;
1547     HANDLE fhand;
1548     char tmpbuf[MAX_PATH+1];
1549     char *tmpstart = tmpbuf;
1550     char *start = path;
1551     char sep;
1552     if (!path)
1553         return Nullch;
1554
1555     /* drive prefix */
1556     if (isALPHA(path[0]) && path[1] == ':') {
1557         start = path + 2;
1558         *tmpstart++ = path[0];
1559         *tmpstart++ = ':';
1560     }
1561     /* UNC prefix */
1562     else if (isSLASH(path[0]) && isSLASH(path[1])) {
1563         start = path + 2;
1564         *tmpstart++ = path[0];
1565         *tmpstart++ = path[1];
1566         SKIP_SLASHES(start);
1567         COPY_NONSLASHES(tmpstart,start);        /* copy machine name */
1568         if (*start) {
1569             *tmpstart++ = *start++;
1570             SKIP_SLASHES(start);
1571             COPY_NONSLASHES(tmpstart,start);    /* copy share name */
1572         }
1573     }
1574     *tmpstart = '\0';
1575     while (*start) {
1576         /* copy initial slash, if any */
1577         if (isSLASH(*start)) {
1578             *tmpstart++ = *start++;
1579             *tmpstart = '\0';
1580             SKIP_SLASHES(start);
1581         }
1582
1583         /* FindFirstFile() expands "." and "..", so we need to pass
1584          * those through unmolested */
1585         if (*start == '.'
1586             && (!start[1] || isSLASH(start[1])
1587                 || (start[1] == '.' && (!start[2] || isSLASH(start[2])))))
1588         {
1589             COPY_NONSLASHES(tmpstart,start);    /* copy "." or ".." */
1590             *tmpstart = '\0';
1591             continue;
1592         }
1593
1594         /* if this is the end, bust outta here */
1595         if (!*start)
1596             break;
1597
1598         /* now we're at a non-slash; walk up to next slash */
1599         while (*start && !isSLASH(*start))
1600             ++start;
1601
1602         /* stop and find full name of component */
1603         sep = *start;
1604         *start = '\0';
1605         fhand = FindFirstFile(path,&fdata);
1606         *start = sep;
1607         if (fhand != INVALID_HANDLE_VALUE) {
1608             STRLEN len = strlen(fdata.cFileName);
1609             if ((STRLEN)(tmpbuf + sizeof(tmpbuf) - tmpstart) > len) {
1610                 strcpy(tmpstart, fdata.cFileName);
1611                 tmpstart += len;
1612                 FindClose(fhand);
1613             }
1614             else {
1615                 FindClose(fhand);
1616                 errno = ERANGE;
1617                 return Nullch;
1618             }
1619         }
1620         else {
1621             /* failed a step, just return without side effects */
1622             /*PerlIO_printf(Perl_debug_log, "Failed to find %s\n", path);*/
1623             errno = EINVAL;
1624             return Nullch;
1625         }
1626     }
1627     strcpy(path,tmpbuf);
1628     return path;
1629 }
1630
1631 static void
1632 out_of_memory()
1633 {
1634     if (PL_curinterp) {
1635         dTHX;
1636         /* Can't use PerlIO to write as it allocates memory */
1637         PerlLIO_write(PerlIO_fileno(Perl_error_log),
1638                       PL_no_mem, strlen(PL_no_mem));
1639         my_exit(1);
1640     }
1641     exit(1);
1642 }
1643
1644 /* The win32_ansipath() function takes a Unicode filename and converts it
1645  * into the current Windows codepage. If some characters cannot be mapped,
1646  * then it will convert the short name instead.
1647  *
1648  * The buffer to the ansi pathname must be freed with win32_free() when it
1649  * it no longer needed.
1650  *
1651  * The argument to win32_ansipath() must exist before this function is
1652  * called; otherwise there is no way to determine the short path name.
1653  *
1654  * Ideas for future refinement:
1655  * - Only convert those segments of the path that are not in the current
1656  *   codepage, but leave the other segments in their long form.
1657  * - If the resulting name is longer than MAX_PATH, start converting
1658  *   additional path segments into short names until the full name
1659  *   is shorter than MAX_PATH.  Shorten the filename part last!
1660  */
1661 DllExport char *
1662 win32_ansipath(const WCHAR *widename)
1663 {
1664     char *name;
1665     BOOL use_default = FALSE;
1666     size_t widelen = wcslen(widename)+1;
1667     int len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, widename, widelen,
1668                                   NULL, 0, NULL, NULL);
1669     name = win32_malloc(len);
1670     if (!name)
1671         out_of_memory();
1672
1673     WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, widename, widelen,
1674                         name, len, NULL, &use_default);
1675     if (use_default) {
1676         DWORD shortlen = GetShortPathNameW(widename, NULL, 0);
1677         if (shortlen) {
1678             WCHAR *shortname = win32_malloc(shortlen*sizeof(WCHAR));
1679             if (!shortname)
1680                 out_of_memory();
1681             shortlen = GetShortPathNameW(widename, shortname, shortlen)+1;
1682
1683             len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, shortname, shortlen,
1684                                       NULL, 0, NULL, NULL);
1685             name = win32_realloc(name, len);
1686             if (!name)
1687                 out_of_memory();
1688             WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, shortname, shortlen,
1689                                 name, len, NULL, NULL);
1690             win32_free(shortname);
1691         }
1692     }
1693     return name;
1694 }
1695
1696 DllExport char *
1697 win32_getenv(const char *name)
1698 {
1699     dTHX;
1700     DWORD needlen;
1701     SV *curitem = Nullsv;
1702
1703     needlen = GetEnvironmentVariableA(name,NULL,0);
1704     if (needlen != 0) {
1705         curitem = sv_2mortal(newSVpvn("", 0));
1706         do {
1707             SvGROW(curitem, needlen+1);
1708             needlen = GetEnvironmentVariableA(name,SvPVX(curitem),
1709                                               needlen);
1710         } while (needlen >= SvLEN(curitem));
1711         SvCUR_set(curitem, needlen);
1712     }
1713     else {
1714         /* allow any environment variables that begin with 'PERL'
1715            to be stored in the registry */
1716         if (strncmp(name, "PERL", 4) == 0)
1717             (void)get_regstr(name, &curitem);
1718     }
1719     if (curitem && SvCUR(curitem))
1720         return SvPVX(curitem);
1721
1722     return Nullch;
1723 }
1724
1725 DllExport int
1726 win32_putenv(const char *name)
1727 {
1728     dTHX;
1729     char* curitem;
1730     char* val;
1731     int relval = -1;
1732
1733     if (name) {
1734         Newx(curitem,strlen(name)+1,char);
1735         strcpy(curitem, name);
1736         val = strchr(curitem, '=');
1737         if (val) {
1738             /* The sane way to deal with the environment.
1739              * Has these advantages over putenv() & co.:
1740              *  * enables us to store a truly empty value in the
1741              *    environment (like in UNIX).
1742              *  * we don't have to deal with RTL globals, bugs and leaks.
1743              *  * Much faster.
1744              * Why you may want to enable USE_WIN32_RTL_ENV:
1745              *  * environ[] and RTL functions will not reflect changes,
1746              *    which might be an issue if extensions want to access
1747              *    the env. via RTL.  This cuts both ways, since RTL will
1748              *    not see changes made by extensions that call the Win32
1749              *    functions directly, either.
1750              * GSAR 97-06-07
1751              */
1752             *val++ = '\0';
1753             if (SetEnvironmentVariableA(curitem, *val ? val : NULL))
1754                 relval = 0;
1755         }
1756         Safefree(curitem);
1757     }
1758     return relval;
1759 }
1760
1761 static long
1762 filetime_to_clock(PFILETIME ft)
1763 {
1764     __int64 qw = ft->dwHighDateTime;
1765     qw <<= 32;
1766     qw |= ft->dwLowDateTime;
1767     qw /= 10000;  /* File time ticks at 0.1uS, clock at 1mS */
1768     return (long) qw;
1769 }
1770
1771 DllExport int
1772 win32_times(struct tms *timebuf)
1773 {
1774     FILETIME user;
1775     FILETIME kernel;
1776     FILETIME dummy;
1777     clock_t process_time_so_far = clock();
1778     if (GetProcessTimes(GetCurrentProcess(), &dummy, &dummy,
1779                         &kernel,&user)) {
1780         timebuf->tms_utime = filetime_to_clock(&user);
1781         timebuf->tms_stime = filetime_to_clock(&kernel);
1782         timebuf->tms_cutime = 0;
1783         timebuf->tms_cstime = 0;
1784     } else {
1785         /* That failed - e.g. Win95 fallback to clock() */
1786         timebuf->tms_utime = process_time_so_far;
1787         timebuf->tms_stime = 0;
1788         timebuf->tms_cutime = 0;
1789         timebuf->tms_cstime = 0;
1790     }
1791     return process_time_so_far;
1792 }
1793
1794 /* fix utime() so it works on directories in NT */
1795 static BOOL
1796 filetime_from_time(PFILETIME pFileTime, time_t Time)
1797 {
1798     struct tm *pTM = localtime(&Time);
1799     SYSTEMTIME SystemTime;
1800     FILETIME LocalTime;
1801
1802     if (pTM == NULL)
1803         return FALSE;
1804
1805     SystemTime.wYear   = pTM->tm_year + 1900;
1806     SystemTime.wMonth  = pTM->tm_mon + 1;
1807     SystemTime.wDay    = pTM->tm_mday;
1808     SystemTime.wHour   = pTM->tm_hour;
1809     SystemTime.wMinute = pTM->tm_min;
1810     SystemTime.wSecond = pTM->tm_sec;
1811     SystemTime.wMilliseconds = 0;
1812
1813     return SystemTimeToFileTime(&SystemTime, &LocalTime) &&
1814            LocalFileTimeToFileTime(&LocalTime, pFileTime);
1815 }
1816
1817 DllExport int
1818 win32_unlink(const char *filename)
1819 {
1820     dTHX;
1821     int ret;
1822     DWORD attrs;
1823
1824     filename = PerlDir_mapA(filename);
1825     attrs = GetFileAttributesA(filename);
1826     if (attrs == 0xFFFFFFFF) {
1827         errno = ENOENT;
1828         return -1;
1829     }
1830     if (attrs & FILE_ATTRIBUTE_READONLY) {
1831         (void)SetFileAttributesA(filename, attrs & ~FILE_ATTRIBUTE_READONLY);
1832         ret = unlink(filename);
1833         if (ret == -1)
1834             (void)SetFileAttributesA(filename, attrs);
1835     }
1836     else
1837         ret = unlink(filename);
1838     return ret;
1839 }
1840
1841 DllExport int
1842 win32_utime(const char *filename, struct utimbuf *times)
1843 {
1844     dTHX;
1845     HANDLE handle;
1846     FILETIME ftCreate;
1847     FILETIME ftAccess;
1848     FILETIME ftWrite;
1849     struct utimbuf TimeBuffer;
1850     int rc;
1851
1852     filename = PerlDir_mapA(filename);
1853     rc = utime(filename, times);
1854
1855     /* EACCES: path specifies directory or readonly file */
1856     if (rc == 0 || errno != EACCES /* || !IsWinNT() */)
1857         return rc;
1858
1859     if (times == NULL) {
1860         times = &TimeBuffer;
1861         time(&times->actime);
1862         times->modtime = times->actime;
1863     }
1864
1865     /* This will (and should) still fail on readonly files */
1866     handle = CreateFileA(filename, GENERIC_READ | GENERIC_WRITE,
1867                          FILE_SHARE_READ | FILE_SHARE_DELETE, NULL,
1868                          OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL);
1869     if (handle == INVALID_HANDLE_VALUE)
1870         return rc;
1871
1872     if (GetFileTime(handle, &ftCreate, &ftAccess, &ftWrite) &&
1873         filetime_from_time(&ftAccess, times->actime) &&
1874         filetime_from_time(&ftWrite, times->modtime) &&
1875         SetFileTime(handle, &ftCreate, &ftAccess, &ftWrite))
1876     {
1877         rc = 0;
1878     }
1879
1880     CloseHandle(handle);
1881     return rc;
1882 }
1883
1884 typedef union {
1885     unsigned __int64    ft_i64;
1886     FILETIME            ft_val;
1887 } FT_t;
1888
1889 #ifdef __GNUC__
1890 #define Const64(x) x##LL
1891 #else
1892 #define Const64(x) x##i64
1893 #endif
1894 /* Number of 100 nanosecond units from 1/1/1601 to 1/1/1970 */
1895 #define EPOCH_BIAS  Const64(116444736000000000)
1896
1897 /* NOTE: This does not compute the timezone info (doing so can be expensive,
1898  * and appears to be unsupported even by glibc) */
1899 DllExport int
1900 win32_gettimeofday(struct timeval *tp, void *not_used)
1901 {
1902     FT_t ft;
1903
1904     /* this returns time in 100-nanosecond units  (i.e. tens of usecs) */
1905     GetSystemTimeAsFileTime(&ft.ft_val);
1906
1907     /* seconds since epoch */
1908     tp->tv_sec = (long)((ft.ft_i64 - EPOCH_BIAS) / Const64(10000000));
1909
1910     /* microseconds remaining */
1911     tp->tv_usec = (long)((ft.ft_i64 / Const64(10)) % Const64(1000000));
1912
1913     return 0;
1914 }
1915
1916 DllExport int
1917 win32_uname(struct utsname *name)
1918 {
1919     struct hostent *hep;
1920     STRLEN nodemax = sizeof(name->nodename)-1;
1921
1922     /* sysname */
1923     switch (g_osver.dwPlatformId) {
1924     case VER_PLATFORM_WIN32_WINDOWS:
1925         strcpy(name->sysname, "Windows");
1926         break;
1927     case VER_PLATFORM_WIN32_NT:
1928         strcpy(name->sysname, "Windows NT");
1929         break;
1930     case VER_PLATFORM_WIN32s:
1931         strcpy(name->sysname, "Win32s");
1932         break;
1933     default:
1934         strcpy(name->sysname, "Win32 Unknown");
1935         break;
1936     }
1937
1938     /* release */
1939     sprintf(name->release, "%d.%d",
1940             g_osver.dwMajorVersion, g_osver.dwMinorVersion);
1941
1942     /* version */
1943     sprintf(name->version, "Build %d",
1944             g_osver.dwPlatformId == VER_PLATFORM_WIN32_NT
1945             ? g_osver.dwBuildNumber : (g_osver.dwBuildNumber & 0xffff));
1946     if (g_osver.szCSDVersion[0]) {
1947         char *buf = name->version + strlen(name->version);
1948         sprintf(buf, " (%s)", g_osver.szCSDVersion);
1949     }
1950
1951     /* nodename */
1952     hep = win32_gethostbyname("localhost");
1953     if (hep) {
1954         STRLEN len = strlen(hep->h_name);
1955         if (len <= nodemax) {
1956             strcpy(name->nodename, hep->h_name);
1957         }
1958         else {
1959             strncpy(name->nodename, hep->h_name, nodemax);
1960             name->nodename[nodemax] = '\0';
1961         }
1962     }
1963     else {
1964         DWORD sz = nodemax;
1965         if (!GetComputerName(name->nodename, &sz))
1966             *name->nodename = '\0';
1967     }
1968
1969     /* machine (architecture) */
1970     {
1971         SYSTEM_INFO info;
1972         DWORD procarch;
1973         char *arch;
1974         GetSystemInfo(&info);
1975
1976 #if (defined(__BORLANDC__)&&(__BORLANDC__<=0x520)) \
1977  || (defined(__MINGW32__) && !defined(_ANONYMOUS_UNION))
1978         procarch = info.u.s.wProcessorArchitecture;
1979 #else
1980         procarch = info.wProcessorArchitecture;
1981 #endif
1982         switch (procarch) {
1983         case PROCESSOR_ARCHITECTURE_INTEL:
1984             arch = "x86"; break;
1985         case PROCESSOR_ARCHITECTURE_MIPS:
1986             arch = "mips"; break;
1987         case PROCESSOR_ARCHITECTURE_ALPHA:
1988             arch = "alpha"; break;
1989         case PROCESSOR_ARCHITECTURE_PPC:
1990             arch = "ppc"; break;
1991 #ifdef PROCESSOR_ARCHITECTURE_SHX
1992         case PROCESSOR_ARCHITECTURE_SHX:
1993             arch = "shx"; break;
1994 #endif
1995 #ifdef PROCESSOR_ARCHITECTURE_ARM
1996         case PROCESSOR_ARCHITECTURE_ARM:
1997             arch = "arm"; break;
1998 #endif
1999 #ifdef PROCESSOR_ARCHITECTURE_IA64
2000         case PROCESSOR_ARCHITECTURE_IA64:
2001             arch = "ia64"; break;
2002 #endif
2003 #ifdef PROCESSOR_ARCHITECTURE_ALPHA64
2004         case PROCESSOR_ARCHITECTURE_ALPHA64:
2005             arch = "alpha64"; break;
2006 #endif
2007 #ifdef PROCESSOR_ARCHITECTURE_MSIL
2008         case PROCESSOR_ARCHITECTURE_MSIL:
2009             arch = "msil"; break;
2010 #endif
2011 #ifdef PROCESSOR_ARCHITECTURE_AMD64
2012         case PROCESSOR_ARCHITECTURE_AMD64:
2013             arch = "amd64"; break;
2014 #endif
2015 #ifdef PROCESSOR_ARCHITECTURE_IA32_ON_WIN64
2016         case PROCESSOR_ARCHITECTURE_IA32_ON_WIN64:
2017             arch = "ia32-64"; break;
2018 #endif
2019 #ifdef PROCESSOR_ARCHITECTURE_UNKNOWN
2020         case PROCESSOR_ARCHITECTURE_UNKNOWN:
2021             arch = "unknown"; break;
2022 #endif
2023         default:
2024             sprintf(name->machine, "unknown(0x%x)", procarch);
2025             arch = name->machine;
2026             break;
2027         }
2028         if (name->machine != arch)
2029             strcpy(name->machine, arch);
2030     }
2031     return 0;
2032 }
2033
2034 /* Timing related stuff */
2035
2036 int
2037 do_raise(pTHX_ int sig) 
2038 {
2039     if (sig < SIG_SIZE) {
2040         Sighandler_t handler = w32_sighandler[sig];
2041         if (handler == SIG_IGN) {
2042             return 0;
2043         }
2044         else if (handler != SIG_DFL) {
2045             (*handler)(sig);
2046             return 0;
2047         }
2048         else {
2049             /* Choose correct default behaviour */
2050             switch (sig) {
2051 #ifdef SIGCLD
2052                 case SIGCLD:
2053 #endif
2054 #ifdef SIGCHLD
2055                 case SIGCHLD:
2056 #endif
2057                 case 0:
2058                     return 0;
2059                 case SIGTERM:
2060                 default:
2061                     break;
2062             }
2063         }
2064     }
2065     /* Tell caller to exit thread/process as approriate */
2066     return 1;
2067 }
2068
2069 void
2070 sig_terminate(pTHX_ int sig)
2071 {
2072     Perl_warn(aTHX_ "Terminating on signal SIG%s(%d)\n",PL_sig_name[sig], sig);
2073     /* exit() seems to be safe, my_exit() or die() is a problem in ^C 
2074        thread 
2075      */
2076     exit(sig);
2077 }
2078
2079 DllExport int
2080 win32_async_check(pTHX)
2081 {
2082     MSG msg;
2083     HWND hwnd = w32_message_hwnd;
2084
2085     w32_poll_count = 0;
2086
2087     if (hwnd == INVALID_HANDLE_VALUE) {
2088         /* Call PeekMessage() to mark all pending messages in the queue as "old".
2089          * This is necessary when we are being called by win32_msgwait() to
2090          * make sure MsgWaitForMultipleObjects() stops reporting the same waiting
2091          * message over and over.  An example how this can happen is when
2092          * Perl is calling win32_waitpid() inside a GUI application and the GUI
2093          * is generating messages before the process terminated.
2094          */
2095         PeekMessage(&msg, NULL, 0, 0, PM_NOREMOVE|PM_NOYIELD);
2096         if (PL_sig_pending)
2097             despatch_signals();
2098         return 1;
2099     }
2100
2101     /* Passing PeekMessage -1 as HWND (2nd arg) only get PostThreadMessage() messages
2102      * and ignores window messages - should co-exist better with windows apps e.g. Tk
2103      */
2104     if (hwnd == NULL)
2105         hwnd = (HWND)-1;
2106
2107     while (PeekMessage(&msg, hwnd, WM_TIMER,    WM_TIMER,    PM_REMOVE|PM_NOYIELD) ||
2108            PeekMessage(&msg, hwnd, WM_USER_MIN, WM_USER_MAX, PM_REMOVE|PM_NOYIELD))
2109     {
2110         switch (msg.message) {
2111 #ifdef USE_ITHREADS
2112         case WM_USER_MESSAGE: {
2113             int child = find_pseudo_pid(msg.wParam);
2114             if (child >= 0)
2115                 w32_pseudo_child_message_hwnds[child] = (HWND)msg.lParam;
2116             break;
2117         }
2118 #endif
2119
2120         case WM_USER_KILL: {
2121             /* We use WM_USER to fake kill() with other signals */
2122             int sig = msg.wParam;
2123             if (do_raise(aTHX_ sig))
2124                 sig_terminate(aTHX_ sig);
2125             break;
2126         }
2127
2128         case WM_TIMER: {
2129             /* alarm() is a one-shot but SetTimer() repeats so kill it */
2130             if (w32_timerid && w32_timerid==msg.wParam) {
2131                 KillTimer(w32_message_hwnd, w32_timerid);
2132                 w32_timerid=0;
2133
2134                 /* Now fake a call to signal handler */
2135                 if (do_raise(aTHX_ 14))
2136                     sig_terminate(aTHX_ 14);
2137             }
2138             break;
2139         }
2140         } /* switch */
2141     }
2142
2143     /* Above or other stuff may have set a signal flag */
2144     if (PL_sig_pending) {
2145         despatch_signals();
2146     }
2147     return 1;
2148 }
2149
2150 /* This function will not return until the timeout has elapsed, or until
2151  * one of the handles is ready. */
2152 DllExport DWORD
2153 win32_msgwait(pTHX_ DWORD count, LPHANDLE handles, DWORD timeout, LPDWORD resultp)
2154 {
2155     /* We may need several goes at this - so compute when we stop */
2156     DWORD ticks = 0;
2157     if (timeout != INFINITE) {
2158         ticks = GetTickCount();
2159         timeout += ticks;
2160     }
2161     while (1) {
2162         DWORD result = MsgWaitForMultipleObjects(count,handles,FALSE,timeout-ticks, QS_POSTMESSAGE|QS_TIMER);
2163         if (resultp)
2164            *resultp = result;
2165         if (result == WAIT_TIMEOUT) {
2166             /* Ran out of time - explicit return of zero to avoid -ve if we
2167                have scheduling issues
2168              */
2169             return 0;
2170         }
2171         if (timeout != INFINITE) {
2172             ticks = GetTickCount();
2173         }
2174         if (result == WAIT_OBJECT_0 + count) {
2175             /* Message has arrived - check it */
2176             (void)win32_async_check(aTHX);
2177         }
2178         else {
2179            /* Not timeout or message - one of handles is ready */
2180            break;
2181         }
2182     }
2183     /* compute time left to wait */
2184     ticks = timeout - ticks;
2185     /* If we are past the end say zero */
2186     return (ticks > 0) ? ticks : 0;
2187 }
2188
2189 int
2190 win32_internal_wait(int *status, DWORD timeout)
2191 {
2192     /* XXX this wait emulation only knows about processes
2193      * spawned via win32_spawnvp(P_NOWAIT, ...).
2194      */
2195     dTHX;
2196     int i, retval;
2197     DWORD exitcode, waitcode;
2198
2199 #ifdef USE_ITHREADS
2200     if (w32_num_pseudo_children) {
2201         win32_msgwait(aTHX_ w32_num_pseudo_children, w32_pseudo_child_handles,
2202                       timeout, &waitcode);
2203         /* Time out here if there are no other children to wait for. */
2204         if (waitcode == WAIT_TIMEOUT) {
2205             if (!w32_num_children) {
2206                 return 0;
2207             }
2208         }
2209         else if (waitcode != WAIT_FAILED) {
2210             if (waitcode >= WAIT_ABANDONED_0
2211                 && waitcode < WAIT_ABANDONED_0 + w32_num_pseudo_children)
2212                 i = waitcode - WAIT_ABANDONED_0;
2213             else
2214                 i = waitcode - WAIT_OBJECT_0;
2215             if (GetExitCodeThread(w32_pseudo_child_handles[i], &exitcode)) {
2216                 *status = (int)((exitcode & 0xff) << 8);
2217                 retval = (int)w32_pseudo_child_pids[i];
2218                 remove_dead_pseudo_process(i);
2219                 return -retval;
2220             }
2221         }
2222     }
2223 #endif
2224
2225     if (!w32_num_children) {
2226         errno = ECHILD;
2227         return -1;
2228     }
2229
2230     /* if a child exists, wait for it to die */
2231     win32_msgwait(aTHX_ w32_num_children, w32_child_handles, timeout, &waitcode);
2232     if (waitcode == WAIT_TIMEOUT) {
2233         return 0;
2234     }
2235     if (waitcode != WAIT_FAILED) {
2236         if (waitcode >= WAIT_ABANDONED_0
2237             && waitcode < WAIT_ABANDONED_0 + w32_num_children)
2238             i = waitcode - WAIT_ABANDONED_0;
2239         else
2240             i = waitcode - WAIT_OBJECT_0;
2241         if (GetExitCodeProcess(w32_child_handles[i], &exitcode) ) {
2242             *status = (int)((exitcode & 0xff) << 8);
2243             retval = (int)w32_child_pids[i];
2244             remove_dead_process(i);
2245             return retval;
2246         }
2247     }
2248
2249     errno = GetLastError();
2250     return -1;
2251 }
2252
2253 DllExport int
2254 win32_waitpid(int pid, int *status, int flags)
2255 {
2256     dTHX;
2257     DWORD timeout = (flags & WNOHANG) ? 0 : INFINITE;
2258     int retval = -1;
2259     long child;
2260     if (pid == -1)                              /* XXX threadid == 1 ? */
2261         return win32_internal_wait(status, timeout);
2262 #ifdef USE_ITHREADS
2263     else if (pid < 0) {
2264         child = find_pseudo_pid(-pid);
2265         if (child >= 0) {
2266             HANDLE hThread = w32_pseudo_child_handles[child];
2267             DWORD waitcode;
2268             win32_msgwait(aTHX_ 1, &hThread, timeout, &waitcode);
2269             if (waitcode == WAIT_TIMEOUT) {
2270                 return 0;
2271             }
2272             else if (waitcode == WAIT_OBJECT_0) {
2273                 if (GetExitCodeThread(hThread, &waitcode)) {
2274                     *status = (int)((waitcode & 0xff) << 8);
2275                     retval = (int)w32_pseudo_child_pids[child];
2276                     remove_dead_pseudo_process(child);
2277                     return -retval;
2278                 }
2279             }
2280             else
2281                 errno = ECHILD;
2282         }
2283         else if (IsWin95()) {
2284             pid = -pid;
2285             goto alien_process;
2286         }
2287     }
2288 #endif
2289     else {
2290         HANDLE hProcess;
2291         DWORD waitcode;
2292         child = find_pid(pid);
2293         if (child >= 0) {
2294             hProcess = w32_child_handles[child];
2295             win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
2296             if (waitcode == WAIT_TIMEOUT) {
2297                 return 0;
2298             }
2299             else if (waitcode == WAIT_OBJECT_0) {
2300                 if (GetExitCodeProcess(hProcess, &waitcode)) {
2301                     *status = (int)((waitcode & 0xff) << 8);
2302                     retval = (int)w32_child_pids[child];
2303                     remove_dead_process(child);
2304                     return retval;
2305                 }
2306             }
2307             else
2308                 errno = ECHILD;
2309         }
2310         else {
2311 alien_process:
2312             hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE,
2313                                    (IsWin95() ? -pid : pid));
2314             if (hProcess) {
2315                 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
2316                 if (waitcode == WAIT_TIMEOUT) {
2317                     CloseHandle(hProcess);
2318                     return 0;
2319                 }
2320                 else if (waitcode == WAIT_OBJECT_0) {
2321                     if (GetExitCodeProcess(hProcess, &waitcode)) {
2322                         *status = (int)((waitcode & 0xff) << 8);
2323                         CloseHandle(hProcess);
2324                         return pid;
2325                     }
2326                 }
2327                 CloseHandle(hProcess);
2328             }
2329             else
2330                 errno = ECHILD;
2331         }
2332     }
2333     return retval >= 0 ? pid : retval;
2334 }
2335
2336 DllExport int
2337 win32_wait(int *status)
2338 {
2339     return win32_internal_wait(status, INFINITE);
2340 }
2341
2342 DllExport unsigned int
2343 win32_sleep(unsigned int t)
2344 {
2345     dTHX;
2346     /* Win32 times are in ms so *1000 in and /1000 out */
2347     return win32_msgwait(aTHX_ 0, NULL, t*1000, NULL)/1000;
2348 }
2349
2350 DllExport unsigned int
2351 win32_alarm(unsigned int sec)
2352 {
2353     /*
2354      * the 'obvious' implentation is SetTimer() with a callback
2355      * which does whatever receiving SIGALRM would do
2356      * we cannot use SIGALRM even via raise() as it is not
2357      * one of the supported codes in <signal.h>
2358      */
2359     dTHX;
2360
2361     if (w32_message_hwnd == INVALID_HANDLE_VALUE)
2362         w32_message_hwnd = win32_create_message_window();
2363
2364     if (sec) {
2365         if (w32_message_hwnd == NULL)
2366             w32_timerid = SetTimer(NULL, w32_timerid, sec*1000, NULL);
2367         else {
2368             w32_timerid = 1;
2369             SetTimer(w32_message_hwnd, w32_timerid, sec*1000, NULL);
2370         }
2371     }
2372     else {
2373         if (w32_timerid) {
2374             KillTimer(w32_message_hwnd, w32_timerid);
2375             w32_timerid = 0;
2376         }
2377     }
2378     return 0;
2379 }
2380
2381 #ifdef HAVE_DES_FCRYPT
2382 extern char *   des_fcrypt(const char *txt, const char *salt, char *cbuf);
2383 #endif
2384
2385 DllExport char *
2386 win32_crypt(const char *txt, const char *salt)
2387 {
2388     dTHX;
2389 #ifdef HAVE_DES_FCRYPT
2390     return des_fcrypt(txt, salt, w32_crypt_buffer);
2391 #else
2392     Perl_croak(aTHX_ "The crypt() function is unimplemented due to excessive paranoia.");
2393     return Nullch;
2394 #endif
2395 }
2396
2397 #ifdef USE_FIXED_OSFHANDLE
2398
2399 #define FOPEN                   0x01    /* file handle open */
2400 #define FNOINHERIT              0x10    /* file handle opened O_NOINHERIT */
2401 #define FAPPEND                 0x20    /* file handle opened O_APPEND */
2402 #define FDEV                    0x40    /* file handle refers to device */
2403 #define FTEXT                   0x80    /* file handle is in text mode */
2404
2405 /***
2406 *int my_open_osfhandle(intptr_t osfhandle, int flags) - open C Runtime file handle
2407 *
2408 *Purpose:
2409 *       This function allocates a free C Runtime file handle and associates
2410 *       it with the Win32 HANDLE specified by the first parameter. This is a
2411 *       temperary fix for WIN95's brain damage GetFileType() error on socket
2412 *       we just bypass that call for socket
2413 *
2414 *       This works with MSVC++ 4.0+ or GCC/Mingw32
2415 *
2416 *Entry:
2417 *       intptr_t osfhandle - Win32 HANDLE to associate with C Runtime file handle.
2418 *       int flags      - flags to associate with C Runtime file handle.
2419 *
2420 *Exit:
2421 *       returns index of entry in fh, if successful
2422 *       return -1, if no free entry is found
2423 *
2424 *Exceptions:
2425 *
2426 *******************************************************************************/
2427
2428 /*
2429  * we fake up some parts of the CRT that aren't exported by MSVCRT.dll
2430  * this lets sockets work on Win9X with GCC and should fix the problems
2431  * with perl95.exe
2432  *      -- BKS, 1-23-2000
2433 */
2434
2435 /* create an ioinfo entry, kill its handle, and steal the entry */
2436
2437 static int
2438 _alloc_osfhnd(void)
2439 {
2440     HANDLE hF = CreateFile("NUL", 0, 0, NULL, OPEN_ALWAYS, 0, NULL);
2441     int fh = _open_osfhandle((intptr_t)hF, 0);
2442     CloseHandle(hF);
2443     if (fh == -1)
2444         return fh;
2445     EnterCriticalSection(&(_pioinfo(fh)->lock));
2446     return fh;
2447 }
2448
2449 static int
2450 my_open_osfhandle(intptr_t osfhandle, int flags)
2451 {
2452     int fh;
2453     char fileflags;             /* _osfile flags */
2454
2455     /* copy relevant flags from second parameter */
2456     fileflags = FDEV;
2457
2458     if (flags & O_APPEND)
2459         fileflags |= FAPPEND;
2460
2461     if (flags & O_TEXT)
2462         fileflags |= FTEXT;
2463
2464     if (flags & O_NOINHERIT)
2465         fileflags |= FNOINHERIT;
2466
2467     /* attempt to allocate a C Runtime file handle */
2468     if ((fh = _alloc_osfhnd()) == -1) {
2469         errno = EMFILE;         /* too many open files */
2470         _doserrno = 0L;         /* not an OS error */
2471         return -1;              /* return error to caller */
2472     }
2473
2474     /* the file is open. now, set the info in _osfhnd array */
2475     _set_osfhnd(fh, osfhandle);
2476
2477     fileflags |= FOPEN;         /* mark as open */
2478
2479     _osfile(fh) = fileflags;    /* set osfile entry */
2480     LeaveCriticalSection(&_pioinfo(fh)->lock);
2481
2482     return fh;                  /* return handle */
2483 }
2484
2485 #endif  /* USE_FIXED_OSFHANDLE */
2486
2487 /* simulate flock by locking a range on the file */
2488
2489 #define LK_ERR(f,i)     ((f) ? (i = 0) : (errno = GetLastError()))
2490 #define LK_LEN          0xffff0000
2491
2492 DllExport int
2493 win32_flock(int fd, int oper)
2494 {
2495     OVERLAPPED o;
2496     int i = -1;
2497     HANDLE fh;
2498
2499     if (!IsWinNT()) {
2500         dTHX;
2501         Perl_croak_nocontext("flock() unimplemented on this platform");
2502         return -1;
2503     }
2504     fh = (HANDLE)_get_osfhandle(fd);
2505     memset(&o, 0, sizeof(o));
2506
2507     switch(oper) {
2508     case LOCK_SH:               /* shared lock */
2509         LK_ERR(LockFileEx(fh, 0, 0, LK_LEN, 0, &o),i);
2510         break;
2511     case LOCK_EX:               /* exclusive lock */
2512         LK_ERR(LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK, 0, LK_LEN, 0, &o),i);
2513         break;
2514     case LOCK_SH|LOCK_NB:       /* non-blocking shared lock */
2515         LK_ERR(LockFileEx(fh, LOCKFILE_FAIL_IMMEDIATELY, 0, LK_LEN, 0, &o),i);
2516         break;
2517     case LOCK_EX|LOCK_NB:       /* non-blocking exclusive lock */
2518         LK_ERR(LockFileEx(fh,
2519                        LOCKFILE_EXCLUSIVE_LOCK|LOCKFILE_FAIL_IMMEDIATELY,
2520                        0, LK_LEN, 0, &o),i);
2521         break;
2522     case LOCK_UN:               /* unlock lock */
2523         LK_ERR(UnlockFileEx(fh, 0, LK_LEN, 0, &o),i);
2524         break;
2525     default:                    /* unknown */
2526         errno = EINVAL;
2527         break;
2528     }
2529     return i;
2530 }
2531
2532 #undef LK_ERR
2533 #undef LK_LEN
2534
2535 /*
2536  *  redirected io subsystem for all XS modules
2537  *
2538  */
2539
2540 DllExport int *
2541 win32_errno(void)
2542 {
2543     return (&errno);
2544 }
2545
2546 DllExport char ***
2547 win32_environ(void)
2548 {
2549     return (&(_environ));
2550 }
2551
2552 /* the rest are the remapped stdio routines */
2553 DllExport FILE *
2554 win32_stderr(void)
2555 {
2556     return (stderr);
2557 }
2558
2559 DllExport FILE *
2560 win32_stdin(void)
2561 {
2562     return (stdin);
2563 }
2564
2565 DllExport FILE *
2566 win32_stdout()
2567 {
2568     return (stdout);
2569 }
2570
2571 DllExport int
2572 win32_ferror(FILE *fp)
2573 {
2574     return (ferror(fp));
2575 }
2576
2577
2578 DllExport int
2579 win32_feof(FILE *fp)
2580 {
2581     return (feof(fp));
2582 }
2583
2584 /*
2585  * Since the errors returned by the socket error function
2586  * WSAGetLastError() are not known by the library routine strerror
2587  * we have to roll our own.
2588  */
2589
2590 DllExport char *
2591 win32_strerror(int e)
2592 {
2593 #if !defined __BORLANDC__ && !defined __MINGW32__      /* compiler intolerance */
2594     extern int sys_nerr;
2595 #endif
2596     DWORD source = 0;
2597
2598     if (e < 0 || e > sys_nerr) {
2599         dTHX;
2600         if (e < 0)
2601             e = GetLastError();
2602
2603         if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, &source, e, 0,
2604                           w32_strerror_buffer,
2605                           sizeof(w32_strerror_buffer), NULL) == 0)
2606             strcpy(w32_strerror_buffer, "Unknown Error");
2607
2608         return w32_strerror_buffer;
2609     }
2610     return strerror(e);
2611 }
2612
2613 DllExport void
2614 win32_str_os_error(void *sv, DWORD dwErr)
2615 {
2616     DWORD dwLen;
2617     char *sMsg;
2618     dwLen = FormatMessageA(FORMAT_MESSAGE_ALLOCATE_BUFFER
2619                           |FORMAT_MESSAGE_IGNORE_INSERTS
2620                           |FORMAT_MESSAGE_FROM_SYSTEM, NULL,
2621                            dwErr, 0, (char *)&sMsg, 1, NULL);
2622     /* strip trailing whitespace and period */
2623     if (0 < dwLen) {
2624         do {
2625             --dwLen;    /* dwLen doesn't include trailing null */
2626         } while (0 < dwLen && isSPACE(sMsg[dwLen]));
2627         if ('.' != sMsg[dwLen])
2628             dwLen++;
2629         sMsg[dwLen] = '\0';
2630     }
2631     if (0 == dwLen) {
2632         sMsg = (char*)LocalAlloc(0, 64/**sizeof(TCHAR)*/);
2633         if (sMsg)
2634             dwLen = sprintf(sMsg,
2635                             "Unknown error #0x%lX (lookup 0x%lX)",
2636                             dwErr, GetLastError());
2637     }
2638     if (sMsg) {
2639         dTHX;
2640         sv_setpvn((SV*)sv, sMsg, dwLen);
2641         LocalFree(sMsg);
2642     }
2643 }
2644
2645 DllExport int
2646 win32_fprintf(FILE *fp, const char *format, ...)
2647 {
2648     va_list marker;
2649     va_start(marker, format);     /* Initialize variable arguments. */
2650
2651     return (vfprintf(fp, format, marker));
2652 }
2653
2654 DllExport int
2655 win32_printf(const char *format, ...)
2656 {
2657     va_list marker;
2658     va_start(marker, format);     /* Initialize variable arguments. */
2659
2660     return (vprintf(format, marker));
2661 }
2662
2663 DllExport int
2664 win32_vfprintf(FILE *fp, const char *format, va_list args)
2665 {
2666     return (vfprintf(fp, format, args));
2667 }
2668
2669 DllExport int
2670 win32_vprintf(const char *format, va_list args)
2671 {
2672     return (vprintf(format, args));
2673 }
2674
2675 DllExport size_t
2676 win32_fread(void *buf, size_t size, size_t count, FILE *fp)
2677 {
2678     return fread(buf, size, count, fp);
2679 }
2680
2681 DllExport size_t
2682 win32_fwrite(const void *buf, size_t size, size_t count, FILE *fp)
2683 {
2684     return fwrite(buf, size, count, fp);
2685 }
2686
2687 #define MODE_SIZE 10
2688
2689 DllExport FILE *
2690 win32_fopen(const char *filename, const char *mode)
2691 {
2692     dTHX;
2693     FILE *f;
2694
2695     if (!*filename)
2696         return NULL;
2697
2698     if (stricmp(filename, "/dev/null")==0)
2699         filename = "NUL";
2700
2701     f = fopen(PerlDir_mapA(filename), mode);
2702     /* avoid buffering headaches for child processes */
2703     if (f && *mode == 'a')
2704         win32_fseek(f, 0, SEEK_END);
2705     return f;
2706 }
2707
2708 #ifndef USE_SOCKETS_AS_HANDLES
2709 #undef fdopen
2710 #define fdopen my_fdopen
2711 #endif
2712
2713 DllExport FILE *
2714 win32_fdopen(int handle, const char *mode)
2715 {
2716     dTHX;
2717     FILE *f;
2718     f = fdopen(handle, (char *) mode);
2719     /* avoid buffering headaches for child processes */
2720     if (f && *mode == 'a')
2721         win32_fseek(f, 0, SEEK_END);
2722     return f;
2723 }
2724
2725 DllExport FILE *
2726 win32_freopen(const char *path, const char *mode, FILE *stream)
2727 {
2728     dTHX;
2729     if (stricmp(path, "/dev/null")==0)
2730         path = "NUL";
2731
2732     return freopen(PerlDir_mapA(path), mode, stream);
2733 }
2734
2735 DllExport int
2736 win32_fclose(FILE *pf)
2737 {
2738     return my_fclose(pf);       /* defined in win32sck.c */
2739 }
2740
2741 DllExport int
2742 win32_fputs(const char *s,FILE *pf)
2743 {
2744     return fputs(s, pf);
2745 }
2746
2747 DllExport int
2748 win32_fputc(int c,FILE *pf)
2749 {
2750     return fputc(c,pf);
2751 }
2752
2753 DllExport int
2754 win32_ungetc(int c,FILE *pf)
2755 {
2756     return ungetc(c,pf);
2757 }
2758
2759 DllExport int
2760 win32_getc(FILE *pf)
2761 {
2762     return getc(pf);
2763 }
2764
2765 DllExport int
2766 win32_fileno(FILE *pf)
2767 {
2768     return fileno(pf);
2769 }
2770
2771 DllExport void
2772 win32_clearerr(FILE *pf)
2773 {
2774     clearerr(pf);
2775     return;
2776 }
2777
2778 DllExport int
2779 win32_fflush(FILE *pf)
2780 {
2781     return fflush(pf);
2782 }
2783
2784 DllExport Off_t
2785 win32_ftell(FILE *pf)
2786 {
2787 #if defined(WIN64) || defined(USE_LARGE_FILES)
2788 #if defined(__BORLANDC__) /* buk */
2789     return win32_tell( fileno( pf ) );
2790 #else
2791     fpos_t pos;
2792     if (fgetpos(pf, &pos))
2793         return -1;
2794     return (Off_t)pos;
2795 #endif
2796 #else
2797     return ftell(pf);
2798 #endif
2799 }
2800
2801 DllExport int
2802 win32_fseek(FILE *pf, Off_t offset,int origin)
2803 {
2804 #if defined(WIN64) || defined(USE_LARGE_FILES)
2805 #if defined(__BORLANDC__) /* buk */
2806     return win32_lseek(
2807         fileno(pf),
2808         offset,
2809         origin
2810         );
2811 #else
2812     fpos_t pos;
2813     switch (origin) {
2814     case SEEK_CUR:
2815         if (fgetpos(pf, &pos))
2816             return -1;
2817         offset += pos;
2818         break;
2819     case SEEK_END:
2820         fseek(pf, 0, SEEK_END);
2821         pos = _telli64(fileno(pf));
2822         offset += pos;
2823         break;
2824     case SEEK_SET:
2825         break;
2826     default:
2827         errno = EINVAL;
2828         return -1;
2829     }
2830     return fsetpos(pf, &offset);
2831 #endif
2832 #else
2833     return fseek(pf, (long)offset, origin);
2834 #endif
2835 }
2836
2837 DllExport int
2838 win32_fgetpos(FILE *pf,fpos_t *p)
2839 {
2840 #if defined(__BORLANDC__) && defined(USE_LARGE_FILES) /* buk */
2841     if( win32_tell(fileno(pf)) == -1L ) {
2842         errno = EBADF;
2843         return -1;
2844     }
2845     return 0;
2846 #else
2847     return fgetpos(pf, p);
2848 #endif
2849 }
2850
2851 DllExport int
2852 win32_fsetpos(FILE *pf,const fpos_t *p)
2853 {
2854 #if defined(__BORLANDC__) && defined(USE_LARGE_FILES) /* buk */
2855     return win32_lseek(fileno(pf), *p, SEEK_CUR);
2856 #else
2857     return fsetpos(pf, p);
2858 #endif
2859 }
2860
2861 DllExport void
2862 win32_rewind(FILE *pf)
2863 {
2864     rewind(pf);
2865     return;
2866 }
2867
2868 DllExport int
2869 win32_tmpfd(void)
2870 {
2871     dTHX;
2872     char prefix[MAX_PATH+1];
2873     char filename[MAX_PATH+1];
2874     DWORD len = GetTempPath(MAX_PATH, prefix);
2875     if (len && len < MAX_PATH) {
2876         if (GetTempFileName(prefix, "plx", 0, filename)) {
2877             HANDLE fh = CreateFile(filename,
2878                                    DELETE | GENERIC_READ | GENERIC_WRITE,
2879                                    0,
2880                                    NULL,
2881                                    CREATE_ALWAYS,
2882                                    FILE_ATTRIBUTE_NORMAL
2883                                    | FILE_FLAG_DELETE_ON_CLOSE,
2884                                    NULL);
2885             if (fh != INVALID_HANDLE_VALUE) {
2886                 int fd = win32_open_osfhandle((intptr_t)fh, 0);
2887                 if (fd >= 0) {
2888 #if defined(__BORLANDC__)
2889                     setmode(fd,O_BINARY);
2890 #endif
2891                     DEBUG_p(PerlIO_printf(Perl_debug_log,
2892                                           "Created tmpfile=%s\n",filename));
2893                     return fd;
2894                 }
2895             }
2896         }
2897     }
2898     return -1;
2899 }
2900
2901 DllExport FILE*
2902 win32_tmpfile(void)
2903 {
2904     int fd = win32_tmpfd();
2905     if (fd >= 0)
2906         return win32_fdopen(fd, "w+b");
2907     return NULL;
2908 }
2909
2910 DllExport void
2911 win32_abort(void)
2912 {
2913     abort();
2914     return;
2915 }
2916
2917 DllExport int
2918 win32_fstat(int fd, Stat_t *sbufptr)
2919 {
2920 #ifdef __BORLANDC__
2921     /* A file designated by filehandle is not shown as accessible
2922      * for write operations, probably because it is opened for reading.
2923      * --Vadim Konovalov
2924      */
2925     BY_HANDLE_FILE_INFORMATION bhfi;
2926 #if defined(WIN64) || defined(USE_LARGE_FILES)    
2927     /* Borland 5.5.1 has a 64-bit stat, but only a 32-bit fstat */
2928     struct stat tmp;
2929     int rc = fstat(fd,&tmp);
2930    
2931     sbufptr->st_dev   = tmp.st_dev;
2932     sbufptr->st_ino   = tmp.st_ino;
2933     sbufptr->st_mode  = tmp.st_mode;
2934     sbufptr->st_nlink = tmp.st_nlink;
2935     sbufptr->st_uid   = tmp.st_uid;
2936     sbufptr->st_gid   = tmp.st_gid;
2937     sbufptr->st_rdev  = tmp.st_rdev;
2938     sbufptr->st_size  = tmp.st_size;
2939     sbufptr->st_atime = tmp.st_atime;
2940     sbufptr->st_mtime = tmp.st_mtime;
2941     sbufptr->st_ctime = tmp.st_ctime;
2942 #else
2943     int rc = fstat(fd,sbufptr);
2944 #endif       
2945
2946     if (GetFileInformationByHandle((HANDLE)_get_osfhandle(fd), &bhfi)) {
2947 #if defined(WIN64) || defined(USE_LARGE_FILES)    
2948         sbufptr->st_size = (bhfi.nFileSizeHigh << 32) + bhfi.nFileSizeLow ;
2949 #endif
2950         sbufptr->st_mode &= 0xFE00;
2951         if (bhfi.dwFileAttributes & FILE_ATTRIBUTE_READONLY)
2952             sbufptr->st_mode |= (S_IREAD + (S_IREAD >> 3) + (S_IREAD >> 6));
2953         else
2954             sbufptr->st_mode |= ((S_IREAD|S_IWRITE) + ((S_IREAD|S_IWRITE) >> 3)
2955               + ((S_IREAD|S_IWRITE) >> 6));
2956     }
2957     return rc;
2958 #else
2959     return my_fstat(fd,sbufptr);
2960 #endif
2961 }
2962
2963 DllExport int
2964 win32_pipe(int *pfd, unsigned int size, int mode)
2965 {
2966     return _pipe(pfd, size, mode);
2967 }
2968
2969 DllExport PerlIO*
2970 win32_popenlist(const char *mode, IV narg, SV **args)
2971 {
2972  dTHX;
2973  Perl_croak(aTHX_ "List form of pipe open not implemented");
2974  return NULL;
2975 }
2976
2977 /*
2978  * a popen() clone that respects PERL5SHELL
2979  *
2980  * changed to return PerlIO* rather than FILE * by BKS, 11-11-2000
2981  */
2982
2983 DllExport PerlIO*
2984 win32_popen(const char *command, const char *mode)
2985 {
2986 #ifdef USE_RTL_POPEN
2987     return _popen(command, mode);
2988 #else
2989     dTHX;
2990     int p[2];
2991     int parent, child;
2992     int stdfd, oldfd;
2993     int ourmode;
2994     int childpid;
2995     DWORD nhandle;
2996     HANDLE old_h;
2997     int lock_held = 0;
2998
2999     /* establish which ends read and write */
3000     if (strchr(mode,'w')) {
3001         stdfd = 0;              /* stdin */
3002         parent = 1;
3003         child = 0;
3004         nhandle = STD_INPUT_HANDLE;
3005     }
3006     else if (strchr(mode,'r')) {
3007         stdfd = 1;              /* stdout */
3008         parent = 0;
3009         child = 1;
3010         nhandle = STD_OUTPUT_HANDLE;
3011     }
3012     else
3013         return NULL;
3014
3015     /* set the correct mode */
3016     if (strchr(mode,'b'))
3017         ourmode = O_BINARY;
3018     else if (strchr(mode,'t'))
3019         ourmode = O_TEXT;
3020     else
3021         ourmode = _fmode & (O_TEXT | O_BINARY);
3022
3023     /* the child doesn't inherit handles */
3024     ourmode |= O_NOINHERIT;
3025
3026     if (win32_pipe(p, 512, ourmode) == -1)
3027         return NULL;
3028
3029     /* save the old std handle (this needs to happen before the
3030      * dup2(), since that might call SetStdHandle() too) */
3031     OP_REFCNT_LOCK;
3032     lock_held = 1;
3033     old_h = GetStdHandle(nhandle);
3034
3035     /* save current stdfd */
3036     if ((oldfd = win32_dup(stdfd)) == -1)
3037         goto cleanup;
3038
3039     /* make stdfd go to child end of pipe (implicitly closes stdfd) */
3040     /* stdfd will be inherited by the child */
3041     if (win32_dup2(p[child], stdfd) == -1)
3042         goto cleanup;
3043
3044     /* close the child end in parent */
3045     win32_close(p[child]);
3046
3047     /* set the new std handle (in case dup2() above didn't) */
3048     SetStdHandle(nhandle, (HANDLE)_get_osfhandle(stdfd));
3049
3050     /* start the child */
3051     {
3052         dTHX;
3053         if ((childpid = do_spawn_nowait((char*)command)) == -1)
3054             goto cleanup;
3055
3056         /* revert stdfd to whatever it was before */
3057         if (win32_dup2(oldfd, stdfd) == -1)
3058             goto cleanup;
3059
3060         /* close saved handle */
3061         win32_close(oldfd);
3062
3063         /* restore the old std handle (this needs to happen after the
3064          * dup2(), since that might call SetStdHandle() too */
3065         if (lock_held) {
3066             SetStdHandle(nhandle, old_h);
3067             OP_REFCNT_UNLOCK;
3068             lock_held = 0;
3069         }
3070
3071         LOCK_FDPID_MUTEX;
3072         sv_setiv(*av_fetch(w32_fdpid, p[parent], TRUE), childpid);
3073         UNLOCK_FDPID_MUTEX;
3074
3075         /* set process id so that it can be returned by perl's open() */
3076         PL_forkprocess = childpid;
3077     }
3078
3079     /* we have an fd, return a file stream */
3080     return (PerlIO_fdopen(p[parent], (char *)mode));
3081
3082 cleanup:
3083     /* we don't need to check for errors here */
3084     win32_close(p[0]);
3085     win32_close(p[1]);
3086     if (oldfd != -1) {
3087         win32_dup2(oldfd, stdfd);
3088         win32_close(oldfd);
3089     }
3090     if (lock_held) {
3091         SetStdHandle(nhandle, old_h);
3092         OP_REFCNT_UNLOCK;
3093         lock_held = 0;
3094     }
3095     return (NULL);
3096
3097 #endif /* USE_RTL_POPEN */
3098 }
3099
3100 /*
3101  * pclose() clone
3102  */
3103
3104 DllExport int
3105 win32_pclose(PerlIO *pf)
3106 {
3107 #ifdef USE_RTL_POPEN
3108     return _pclose(pf);
3109 #else
3110     dTHX;
3111     int childpid, status;
3112     SV *sv;
3113
3114     LOCK_FDPID_MUTEX;
3115     sv = *av_fetch(w32_fdpid, PerlIO_fileno(pf), TRUE);
3116
3117     if (SvIOK(sv))
3118         childpid = SvIVX(sv);
3119     else
3120         childpid = 0;
3121
3122     if (!childpid) {
3123         UNLOCK_FDPID_MUTEX;
3124         errno = EBADF;
3125         return -1;
3126     }
3127
3128 #ifdef USE_PERLIO
3129     PerlIO_close(pf);
3130 #else
3131     fclose(pf);
3132 #endif
3133     SvIVX(sv) = 0;
3134     UNLOCK_FDPID_MUTEX;
3135
3136     if (win32_waitpid(childpid, &status, 0) == -1)
3137         return -1;
3138
3139     return status;
3140
3141 #endif /* USE_RTL_POPEN */
3142 }
3143
3144 static BOOL WINAPI
3145 Nt4CreateHardLinkW(
3146     LPCWSTR lpFileName,
3147     LPCWSTR lpExistingFileName,
3148     LPSECURITY_ATTRIBUTES lpSecurityAttributes)
3149 {
3150     HANDLE handle;
3151     WCHAR wFullName[MAX_PATH+1];
3152     LPVOID lpContext = NULL;
3153     WIN32_STREAM_ID StreamId;
3154     DWORD dwSize = (char*)&StreamId.cStreamName - (char*)&StreamId;
3155     DWORD dwWritten;
3156     DWORD dwLen;
3157     BOOL bSuccess;
3158
3159     BOOL (__stdcall *pfnBackupWrite)(HANDLE, LPBYTE, DWORD, LPDWORD,
3160                                      BOOL, BOOL, LPVOID*) =
3161         (BOOL (__stdcall *)(HANDLE, LPBYTE, DWORD, LPDWORD,
3162                             BOOL, BOOL, LPVOID*))
3163         GetProcAddress(GetModuleHandle("kernel32.dll"), "BackupWrite");
3164     if (pfnBackupWrite == NULL)
3165         return 0;
3166
3167     dwLen = GetFullPathNameW(lpFileName, MAX_PATH, wFullName, NULL);
3168     if (dwLen == 0)
3169         return 0;
3170     dwLen = (dwLen+1)*sizeof(WCHAR);
3171
3172     handle = CreateFileW(lpExistingFileName, FILE_WRITE_ATTRIBUTES,
3173                          FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,
3174                          NULL, OPEN_EXISTING, 0, NULL);
3175     if (handle == INVALID_HANDLE_VALUE)
3176         return 0;
3177
3178     StreamId.dwStreamId = BACKUP_LINK;
3179     StreamId.dwStreamAttributes = 0;
3180     StreamId.dwStreamNameSize = 0;
3181 #if defined(__BORLANDC__) \
3182  ||(defined(__MINGW32__) && !defined(_ANONYMOUS_UNION))
3183     StreamId.Size.u.HighPart = 0;
3184     StreamId.Size.u.LowPart = dwLen;
3185 #else
3186     StreamId.Size.HighPart = 0;
3187     StreamId.Size.LowPart = dwLen;
3188 #endif
3189
3190     bSuccess = pfnBackupWrite(handle, (LPBYTE)&StreamId, dwSize, &dwWritten,
3191                               FALSE, FALSE, &lpContext);
3192     if (bSuccess) {
3193         bSuccess = pfnBackupWrite(handle, (LPBYTE)wFullName, dwLen, &dwWritten,
3194                                   FALSE, FALSE, &lpContext);
3195         pfnBackupWrite(handle, NULL, 0, &dwWritten, TRUE, FALSE, &lpContext);
3196     }
3197
3198     CloseHandle(handle);
3199     return bSuccess;
3200 }
3201
3202 DllExport int
3203 win32_link(const char *oldname, const char *newname)
3204 {
3205     dTHX;
3206     BOOL (__stdcall *pfnCreateHardLinkW)(LPCWSTR,LPCWSTR,LPSECURITY_ATTRIBUTES);
3207     WCHAR wOldName[MAX_PATH+1];
3208     WCHAR wNewName[MAX_PATH+1];
3209
3210     if (IsWin95())
3211         Perl_croak(aTHX_ PL_no_func, "link");
3212
3213     pfnCreateHardLinkW =
3214         (BOOL (__stdcall *)(LPCWSTR, LPCWSTR, LPSECURITY_ATTRIBUTES))
3215         GetProcAddress(GetModuleHandle("kernel32.dll"), "CreateHardLinkW");
3216     if (pfnCreateHardLinkW == NULL)
3217         pfnCreateHardLinkW = Nt4CreateHardLinkW;
3218
3219     if (MultiByteToWideChar(CP_ACP, 0, oldname, -1, wOldName, MAX_PATH+1) &&
3220         MultiByteToWideChar(CP_ACP, 0, newname, -1, wNewName, MAX_PATH+1) &&
3221         (wcscpy(wOldName, PerlDir_mapW(wOldName)),
3222         pfnCreateHardLinkW(PerlDir_mapW(wNewName), wOldName, NULL)))
3223     {
3224         return 0;
3225     }
3226     errno = (GetLastError() == ERROR_FILE_NOT_FOUND) ? ENOENT : EINVAL;
3227     return -1;
3228 }
3229
3230 DllExport int
3231 win32_rename(const char *oname, const char *newname)
3232 {
3233     char szOldName[MAX_PATH+1];
3234     char szNewName[MAX_PATH+1];
3235     BOOL bResult;
3236     dTHX;
3237
3238     /* XXX despite what the documentation says about MoveFileEx(),
3239      * it doesn't work under Windows95!
3240      */
3241     if (IsWinNT()) {
3242         DWORD dwFlags = MOVEFILE_COPY_ALLOWED;
3243         if (stricmp(newname, oname))
3244             dwFlags |= MOVEFILE_REPLACE_EXISTING;
3245         strcpy(szOldName, PerlDir_mapA(oname));
3246         bResult = MoveFileExA(szOldName,PerlDir_mapA(newname), dwFlags);
3247         if (!bResult) {
3248             DWORD err = GetLastError();
3249             switch (err) {
3250             case ERROR_BAD_NET_NAME:
3251             case ERROR_BAD_NETPATH:
3252             case ERROR_BAD_PATHNAME:
3253             case ERROR_FILE_NOT_FOUND:
3254             case ERROR_FILENAME_EXCED_RANGE:
3255             case ERROR_INVALID_DRIVE:
3256             case ERROR_NO_MORE_FILES:
3257             case ERROR_PATH_NOT_FOUND:
3258                 errno = ENOENT;
3259                 break;
3260             default:
3261                 errno = EACCES;
3262                 break;
3263             }
3264             return -1;
3265         }
3266         return 0;
3267     }
3268     else {
3269         int retval = 0;
3270         char szTmpName[MAX_PATH+1];
3271         char dname[MAX_PATH+1];
3272         char *endname = Nullch;
3273         STRLEN tmplen = 0;
3274         DWORD from_attr, to_attr;
3275
3276         strcpy(szOldName, PerlDir_mapA(oname));
3277         strcpy(szNewName, PerlDir_mapA(newname));
3278
3279         /* if oname doesn't exist, do nothing */
3280         from_attr = GetFileAttributes(szOldName);
3281         if (from_attr == 0xFFFFFFFF) {
3282             errno = ENOENT;
3283             return -1;
3284         }
3285
3286         /* if newname exists, rename it to a temporary name so that we
3287          * don't delete it in case oname happens to be the same file
3288          * (but perhaps accessed via a different path)
3289          */
3290         to_attr = GetFileAttributes(szNewName);
3291         if (to_attr != 0xFFFFFFFF) {
3292             /* if newname is a directory, we fail
3293              * XXX could overcome this with yet more convoluted logic */
3294             if (to_attr & FILE_ATTRIBUTE_DIRECTORY) {
3295                 errno = EACCES;
3296                 return -1;
3297             }
3298             tmplen = strlen(szNewName);
3299             strcpy(szTmpName,szNewName);
3300             endname = szTmpName+tmplen;
3301             for (; endname > szTmpName ; --endname) {
3302                 if (*endname == '/' || *endname == '\\') {
3303                     *endname = '\0';
3304                     break;
3305                 }
3306             }
3307             if (endname > szTmpName)
3308                 endname = strcpy(dname,szTmpName);
3309             else
3310                 endname = ".";
3311
3312             /* get a temporary filename in same directory
3313              * XXX is this really the best we can do? */
3314             if (!GetTempFileName((LPCTSTR)endname, "plr", 0, szTmpName)) {
3315                 errno = ENOENT;
3316                 return -1;
3317             }
3318             DeleteFile(szTmpName);
3319
3320             retval = rename(szNewName, szTmpName);
3321             if (retval != 0) {
3322                 errno = EACCES;
3323                 return retval;
3324             }
3325         }
3326
3327         /* rename oname to newname */
3328         retval = rename(szOldName, szNewName);
3329
3330         /* if we created a temporary file before ... */
3331         if (endname != Nullch) {
3332             /* ...and rename succeeded, delete temporary file/directory */
3333             if (retval == 0)
3334                 DeleteFile(szTmpName);
3335             /* else restore it to what it was */
3336             else
3337                 (void)rename(szTmpName, szNewName);
3338         }
3339         return retval;
3340     }
3341 }
3342
3343 DllExport int
3344 win32_setmode(int fd, int mode)
3345 {
3346     return setmode(fd, mode);
3347 }
3348
3349 DllExport int
3350 win32_chsize(int fd, Off_t size)
3351 {
3352 #if defined(WIN64) || defined(USE_LARGE_FILES)
3353     int retval = 0;
3354     Off_t cur, end, extend;
3355
3356     cur = win32_tell(fd);
3357     if (cur < 0)
3358         return -1;
3359     end = win32_lseek(fd, 0, SEEK_END);
3360     if (end < 0)
3361         return -1;
3362     extend = size - end;
3363     if (extend == 0) {
3364         /* do nothing */
3365     }
3366     else if (extend > 0) {
3367         /* must grow the file, padding with nulls */
3368         char b[4096];
3369         int oldmode = win32_setmode(fd, O_BINARY);
3370         size_t count;
3371         memset(b, '\0', sizeof(b));
3372         do {
3373             count = extend >= sizeof(b) ? sizeof(b) : (size_t)extend;
3374             count = win32_write(fd, b, count);
3375             if ((int)count < 0) {
3376                 retval = -1;
3377                 break;
3378             }
3379         } while ((extend -= count) > 0);
3380         win32_setmode(fd, oldmode);
3381     }
3382     else {
3383         /* shrink the file */
3384         win32_lseek(fd, size, SEEK_SET);
3385         if (!SetEndOfFile((HANDLE)_get_osfhandle(fd))) {
3386             errno = EACCES;
3387             retval = -1;
3388         }
3389     }
3390 finish:
3391     win32_lseek(fd, cur, SEEK_SET);
3392     return retval;
3393 #else
3394     return chsize(fd, (long)size);
3395 #endif
3396 }
3397
3398 DllExport Off_t
3399 win32_lseek(int fd, Off_t offset, int origin)
3400 {
3401 #if defined(WIN64) || defined(USE_LARGE_FILES)
3402 #if defined(__BORLANDC__) /* buk */
3403     LARGE_INTEGER pos;
3404     pos.QuadPart = offset;
3405     pos.LowPart = SetFilePointer(
3406         (HANDLE)_get_osfhandle(fd),
3407         pos.LowPart,
3408         &pos.HighPart,
3409         origin
3410     );
3411     if (pos.LowPart == INVALID_SET_FILE_POINTER && GetLastError() != NO_ERROR) {
3412         pos.QuadPart = -1;
3413     }
3414
3415     return pos.QuadPart;
3416 #else
3417     return _lseeki64(fd, offset, origin);
3418 #endif
3419 #else
3420     return lseek(fd, (long)offset, origin);
3421 #endif
3422 }
3423
3424 DllExport Off_t
3425 win32_tell(int fd)
3426 {
3427 #if defined(WIN64) || defined(USE_LARGE_FILES)
3428 #if defined(__BORLANDC__) /* buk */
3429     LARGE_INTEGER pos;
3430     pos.QuadPart = 0;
3431     pos.LowPart = SetFilePointer(
3432         (HANDLE)_get_osfhandle(fd),
3433         pos.LowPart,
3434         &pos.HighPart,
3435         FILE_CURRENT
3436     );
3437     if (pos.LowPart == INVALID_SET_FILE_POINTER && GetLastError() != NO_ERROR) {
3438         pos.QuadPart = -1;
3439     }
3440
3441     return pos.QuadPart;
3442     /* return tell(fd); */
3443 #else
3444     return _telli64(fd);
3445 #endif
3446 #else
3447     return tell(fd);
3448 #endif
3449 }
3450
3451 DllExport int
3452 win32_open(const char *path, int flag, ...)
3453 {
3454     dTHX;
3455     va_list ap;
3456     int pmode;
3457
3458     va_start(ap, flag);
3459     pmode = va_arg(ap, int);
3460     va_end(ap);
3461
3462     if (stricmp(path, "/dev/null")==0)
3463         path = "NUL";
3464
3465     return open(PerlDir_mapA(path), flag, pmode);
3466 }
3467
3468 /* close() that understands socket */
3469 extern int my_close(int);       /* in win32sck.c */
3470
3471 DllExport int
3472 win32_close(int fd)
3473 {
3474     return my_close(fd);
3475 }
3476
3477 DllExport int
3478 win32_eof(int fd)
3479 {
3480     return eof(fd);
3481 }
3482
3483 DllExport int
3484 win32_dup(int fd)
3485 {
3486     return dup(fd);
3487 }
3488
3489 DllExport int
3490 win32_dup2(int fd1,int fd2)
3491 {
3492     return dup2(fd1,fd2);
3493 }
3494
3495 #ifdef PERL_MSVCRT_READFIX
3496
3497 #define LF              10      /* line feed */
3498 #define CR              13      /* carriage return */
3499 #define CTRLZ           26      /* ctrl-z means eof for text */
3500 #define FOPEN           0x01    /* file handle open */
3501 #define FEOFLAG         0x02    /* end of file has been encountered */
3502 #define FCRLF           0x04    /* CR-LF across read buffer (in text mode) */
3503 #define FPIPE           0x08    /* file handle refers to a pipe */
3504 #define FAPPEND         0x20    /* file handle opened O_APPEND */
3505 #define FDEV            0x40    /* file handle refers to device */
3506 #define FTEXT           0x80    /* file handle is in text mode */
3507 #define MAX_DESCRIPTOR_COUNT    (64*32) /* this is the maximun that MSVCRT can handle */
3508
3509 int __cdecl
3510 _fixed_read(int fh, void *buf, unsigned cnt)
3511 {
3512     int bytes_read;                 /* number of bytes read */
3513     char *buffer;                   /* buffer to read to */
3514     int os_read;                    /* bytes read on OS call */
3515     char *p, *q;                    /* pointers into buffer */
3516     char peekchr;                   /* peek-ahead character */
3517     ULONG filepos;                  /* file position after seek */
3518     ULONG dosretval;                /* o.s. return value */
3519
3520     /* validate handle */
3521     if (((unsigned)fh >= (unsigned)MAX_DESCRIPTOR_COUNT) ||
3522          !(_osfile(fh) & FOPEN))
3523     {
3524         /* out of range -- return error */
3525         errno = EBADF;
3526         _doserrno = 0;  /* not o.s. error */
3527         return -1;
3528     }
3529
3530     /*
3531      * If lockinitflag is FALSE, assume fd is device
3532      * lockinitflag is set to TRUE by open.
3533      */
3534     if (_pioinfo(fh)->lockinitflag)
3535         EnterCriticalSection(&(_pioinfo(fh)->lock));  /* lock file */
3536
3537     bytes_read = 0;                 /* nothing read yet */
3538     buffer = (char*)buf;
3539
3540     if (cnt == 0 || (_osfile(fh) & FEOFLAG)) {
3541         /* nothing to read or at EOF, so return 0 read */
3542         goto functionexit;
3543     }
3544
3545     if ((_osfile(fh) & (FPIPE|FDEV)) && _pipech(fh) != LF) {
3546         /* a pipe/device and pipe lookahead non-empty: read the lookahead
3547          * char */
3548         *buffer++ = _pipech(fh);
3549         ++bytes_read;
3550         --cnt;
3551         _pipech(fh) = LF;           /* mark as empty */
3552     }
3553
3554     /* read the data */
3555
3556     if (!ReadFile((HANDLE)_osfhnd(fh), buffer, cnt, (LPDWORD)&os_read, NULL))
3557     {
3558         /* ReadFile has reported an error. recognize two special cases.
3559          *
3560          *      1. map ERROR_ACCESS_DENIED to EBADF
3561          *
3562          *      2. just return 0 if ERROR_BROKEN_PIPE has occurred. it
3563          *         means the handle is a read-handle on a pipe for which
3564          *         all write-handles have been closed and all data has been
3565          *         read. */
3566
3567         if ((dosretval = GetLastError()) == ERROR_ACCESS_DENIED) {
3568             /* wrong read/write mode should return EBADF, not EACCES */
3569             errno = EBADF;
3570             _doserrno = dosretval;
3571             bytes_read = -1;
3572             goto functionexit;
3573         }
3574         else if (dosretval == ERROR_BROKEN_PIPE) {
3575             bytes_read = 0;
3576             goto functionexit;
3577         }
3578         else {
3579             bytes_read = -1;
3580             goto functionexit;
3581         }
3582     }
3583
3584     bytes_read += os_read;          /* update bytes read */
3585
3586     if (_osfile(fh) & FTEXT) {
3587         /* now must translate CR-LFs to LFs in the buffer */
3588
3589         /* set CRLF flag to indicate LF at beginning of buffer */
3590         /* if ((os_read != 0) && (*(char *)buf == LF))   */
3591         /*    _osfile(fh) |= FCRLF;                      */
3592         /* else                                          */
3593         /*    _osfile(fh) &= ~FCRLF;                     */
3594
3595         _osfile(fh) &= ~FCRLF;
3596
3597         /* convert chars in the buffer: p is src, q is dest */
3598         p = q = (char*)buf;
3599         while (p < (char *)buf + bytes_read) {
3600             if (*p == CTRLZ) {
3601                 /* if fh is not a device, set ctrl-z flag */
3602                 if (!(_osfile(fh) & FDEV))
3603                     _osfile(fh) |= FEOFLAG;
3604                 break;              /* stop translating */
3605             }
3606             else if (*p != CR)
3607                 *q++ = *p++;
3608             else {
3609                 /* *p is CR, so must check next char for LF */
3610                 if (p < (char *)buf + bytes_read - 1) {
3611                     if (*(p+1) == LF) {
3612                         p += 2;
3613                         *q++ = LF;  /* convert CR-LF to LF */
3614                     }
3615                     else
3616                         *q++ = *p++;    /* store char normally */
3617                 }
3618                 else {
3619                     /* This is the hard part.  We found a CR at end of
3620                        buffer.  We must peek ahead to see if next char
3621                        is an LF. */
3622                     ++p;
3623
3624                     dosretval = 0;
3625                     if (!ReadFile((HANDLE)_osfhnd(fh), &peekchr, 1,
3626                                     (LPDWORD)&os_read, NULL))
3627                         dosretval = GetLastError();
3628
3629                     if (dosretval != 0 || os_read == 0) {
3630                         /* couldn't read ahead, store CR */
3631                         *q++ = CR;
3632                     }
3633                     else {
3634                         /* peekchr now has the extra character -- we now
3635                            have several possibilities:
3636                            1. disk file and char is not LF; just seek back
3637                               and copy CR
3638                            2. disk file and char is LF; store LF, don't seek back
3639                            3. pipe/device and char is LF; store LF.
3640                            4. pipe/device and char isn't LF, store CR and
3641                               put char in pipe lookahead buffer. */
3642                         if (_osfile(fh) & (FDEV|FPIPE)) {
3643                             /* non-seekable device */
3644                             if (peekchr == LF)
3645                                 *q++ = LF;
3646                             else {
3647                                 *q++ = CR;
3648                                 _pipech(fh) = peekchr;
3649                             }
3650                         }
3651                         else {
3652                             /* disk file */
3653                             if (peekchr == LF) {
3654                                 /* nothing read yet; must make some
3655                                    progress */
3656                                 *q++ = LF;
3657                                 /* turn on this flag for tell routine */
3658                                 _osfile(fh) |= FCRLF;
3659                             }
3660                             else {
3661                                 HANDLE osHandle;        /* o.s. handle value */
3662                                 /* seek back */
3663                                 if ((osHandle = (HANDLE)_get_osfhandle(fh)) != (HANDLE)-1)
3664                                 {
3665                                     if ((filepos = SetFilePointer(osHandle, -1, NULL, FILE_CURRENT)) == -1)
3666                                         dosretval = GetLastError();
3667                                 }
3668                                 if (peekchr != LF)
3669                                     *q++ = CR;
3670                             }
3671                         }
3672                     }
3673                 }
3674             }
3675         }
3676
3677         /* we now change bytes_read to reflect the true number of chars
3678            in the buffer */
3679         bytes_read = q - (char *)buf;
3680     }
3681
3682 functionexit:
3683     if (_pioinfo(fh)->lockinitflag)
3684         LeaveCriticalSection(&(_pioinfo(fh)->lock));    /* unlock file */
3685
3686     return bytes_read;
3687 }
3688
3689 #endif  /* PERL_MSVCRT_READFIX */
3690
3691 DllExport int
3692 win32_read(int fd, void *buf, unsigned int cnt)
3693 {
3694 #ifdef PERL_MSVCRT_READFIX
3695     return _fixed_read(fd, buf, cnt);
3696 #else
3697     return read(fd, buf, cnt);
3698 #endif
3699 }
3700
3701 DllExport int
3702 win32_write(int fd, const void *buf, unsigned int cnt)
3703 {
3704     return write(fd, buf, cnt);
3705 }
3706
3707 DllExport int
3708 win32_mkdir(const char *dir, int mode)
3709 {
3710     dTHX;
3711     return mkdir(PerlDir_mapA(dir)); /* just ignore mode */
3712 }
3713
3714 DllExport int
3715 win32_rmdir(const char *dir)
3716 {
3717     dTHX;
3718     return rmdir(PerlDir_mapA(dir));
3719 }
3720
3721 DllExport int
3722 win32_chdir(const char *dir)
3723 {
3724     dTHX;
3725     if (!dir) {
3726         errno = ENOENT;
3727         return -1;
3728     }
3729     return chdir(dir);
3730 }
3731
3732 DllExport  int
3733 win32_access(const char *path, int mode)
3734 {
3735     dTHX;
3736     return access(PerlDir_mapA(path), mode);
3737 }
3738
3739 DllExport  int
3740 win32_chmod(const char *path, int mode)
3741 {
3742     dTHX;
3743     return chmod(PerlDir_mapA(path), mode);
3744 }
3745
3746
3747 static char *
3748 create_command_line(char *cname, STRLEN clen, const char * const *args)
3749 {
3750     dTHX;
3751     int index, argc;
3752     char *cmd, *ptr;
3753     const char *arg;
3754     STRLEN len = 0;
3755     bool bat_file = FALSE;
3756     bool cmd_shell = FALSE;
3757     bool dumb_shell = FALSE;
3758     bool extra_quotes = FALSE;
3759     bool quote_next = FALSE;
3760
3761     if (!cname)
3762         cname = (char*)args[0];
3763
3764     /* The NT cmd.exe shell has the following peculiarity that needs to be
3765      * worked around.  It strips a leading and trailing dquote when any
3766      * of the following is true:
3767      *    1. the /S switch was used
3768      *    2. there are more than two dquotes
3769      *    3. there is a special character from this set: &<>()@^|
3770      *    4. no whitespace characters within the two dquotes
3771      *    5. string between two dquotes isn't an executable file
3772      * To work around this, we always add a leading and trailing dquote
3773      * to the string, if the first argument is either "cmd.exe" or "cmd",
3774      * and there were at least two or more arguments passed to cmd.exe
3775      * (not including switches).
3776      * XXX the above rules (from "cmd /?") don't seem to be applied
3777      * always, making for the convolutions below :-(
3778      */
3779     if (cname) {
3780         if (!clen)
3781             clen = strlen(cname);
3782
3783         if (clen > 4
3784             && (stricmp(&cname[clen-4], ".bat") == 0
3785                 || (IsWinNT() && stricmp(&cname[clen-4], ".cmd") == 0)))
3786         {
3787             bat_file = TRUE;
3788             if (!IsWin95())
3789                 len += 3;
3790         }
3791         else {
3792             char *exe = strrchr(cname, '/');
3793             char *exe2 = strrchr(cname, '\\');
3794             if (exe2 > exe)
3795                 exe = exe2;
3796             if (exe)
3797                 ++exe;
3798             else
3799                 exe = cname;
3800             if (stricmp(exe, "cmd.exe") == 0 || stricmp(exe, "cmd") == 0) {
3801                 cmd_shell = TRUE;
3802                 len += 3;
3803             }
3804             else if (stricmp(exe, "command.com") == 0
3805                      || stricmp(exe, "command") == 0)
3806             {
3807                 dumb_shell = TRUE;
3808             }
3809         }
3810     }
3811
3812     DEBUG_p(PerlIO_printf(Perl_debug_log, "Args "));
3813     for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3814         STRLEN curlen = strlen(arg);
3815         if (!(arg[0] == '"' && arg[curlen-1] == '"'))
3816             len += 2;   /* assume quoting needed (worst case) */
3817         len += curlen + 1;
3818         DEBUG_p(PerlIO_printf(Perl_debug_log, "[%s]",arg));
3819     }
3820     DEBUG_p(PerlIO_printf(Perl_debug_log, "\n"));
3821
3822     argc = index;
3823     Newx(cmd, len, char);
3824     ptr = cmd;
3825
3826     if (bat_file && !IsWin95()) {
3827         *ptr++ = '"';
3828         extra_quotes = TRUE;
3829     }
3830
3831     for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3832         bool do_quote = 0;
3833         STRLEN curlen = strlen(arg);
3834
3835         /* we want to protect empty arguments and ones with spaces with
3836          * dquotes, but only if they aren't already there */
3837         if (!dumb_shell) {
3838             if (!curlen) {
3839                 do_quote = 1;
3840             }
3841             else if (quote_next) {
3842                 /* see if it really is multiple arguments pretending to
3843                  * be one and force a set of quotes around it */
3844                 if (*find_next_space(arg))
3845                     do_quote = 1;
3846             }
3847             else if (!(arg[0] == '"' && curlen > 1 && arg[curlen-1] == '"')) {
3848                 STRLEN i = 0;
3849                 while (i < curlen) {
3850                     if (isSPACE(arg[i])) {
3851                         do_quote = 1;
3852                     }
3853                     else if (arg[i] == '"') {
3854                         do_quote = 0;
3855                         break;
3856                     }
3857                     i++;
3858                 }
3859             }
3860         }
3861
3862         if (do_quote)
3863             *ptr++ = '"';
3864
3865         strcpy(ptr, arg);
3866         ptr += curlen;
3867
3868         if (do_quote)
3869             *ptr++ = '"';
3870
3871         if (args[index+1])
3872             *ptr++ = ' ';
3873
3874         if (!extra_quotes
3875             && cmd_shell
3876             && curlen >= 2
3877             && *arg  == '/'     /* see if arg is "/c", "/x/c", "/x/d/c" etc. */
3878             && stricmp(arg+curlen-2, "/c") == 0)
3879         {
3880             /* is there a next argument? */
3881             if (args[index+1]) {
3882                 /* are there two or more next arguments? */
3883                 if (args[index+2]) {
3884                     *ptr++ = '"';
3885                     extra_quotes = TRUE;
3886                 }
3887                 else {
3888                     /* single argument, force quoting if it has spaces */
3889                     quote_next = TRUE;
3890                 }
3891             }
3892         }
3893     }
3894
3895     if (extra_quotes)
3896         *ptr++ = '"';
3897
3898     *ptr = '\0';
3899
3900     return cmd;
3901 }
3902
3903 static char *
3904 qualified_path(const char *cmd)
3905 {
3906     dTHX;
3907     char *pathstr;
3908     char *fullcmd, *curfullcmd;
3909     STRLEN cmdlen = 0;
3910     int has_slash = 0;
3911
3912     if (!cmd)
3913         return Nullch;
3914     fullcmd = (char*)cmd;
3915     while (*fullcmd) {
3916         if (*fullcmd == '/' || *fullcmd == '\\')
3917             has_slash++;
3918         fullcmd++;
3919         cmdlen++;
3920     }
3921
3922     /* look in PATH */
3923     pathstr = PerlEnv_getenv("PATH");
3924
3925     /* worst case: PATH is a single directory; we need additional space
3926      * to append "/", ".exe" and trailing "\0" */
3927     Newx(fullcmd, (pathstr ? strlen(pathstr) : 0) + cmdlen + 6, char);
3928     curfullcmd = fullcmd;
3929
3930     while (1) {
3931         DWORD res;
3932
3933         /* start by appending the name to the current prefix */
3934         strcpy(curfullcmd, cmd);
3935         curfullcmd += cmdlen;
3936
3937         /* if it doesn't end with '.', or has no extension, try adding
3938          * a trailing .exe first */
3939         if (cmd[cmdlen-1] != '.'
3940             && (cmdlen < 4 || cmd[cmdlen-4] != '.'))
3941         {
3942             strcpy(curfullcmd, ".exe");
3943             res = GetFileAttributes(fullcmd);
3944             if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3945                 return fullcmd;
3946             *curfullcmd = '\0';
3947         }
3948
3949         /* that failed, try the bare name */
3950         res = GetFileAttributes(fullcmd);
3951         if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3952             return fullcmd;
3953
3954         /* quit if no other path exists, or if cmd already has path */
3955         if (!pathstr || !*pathstr || has_slash)
3956             break;
3957
3958         /* skip leading semis */
3959         while (*pathstr == ';')
3960             pathstr++;
3961
3962         /* build a new prefix from scratch */
3963         curfullcmd = fullcmd;
3964         while (*pathstr && *pathstr != ';') {
3965             if (*pathstr == '"') {      /* foo;"baz;etc";bar */
3966                 pathstr++;              /* skip initial '"' */
3967                 while (*pathstr && *pathstr != '"') {
3968                     *curfullcmd++ = *pathstr++;
3969                 }
3970                 if (*pathstr)
3971                     pathstr++;          /* skip trailing '"' */
3972             }
3973             else {
3974                 *curfullcmd++ = *pathstr++;
3975             }
3976         }
3977         if (*pathstr)
3978             pathstr++;                  /* skip trailing semi */
3979         if (curfullcmd > fullcmd        /* append a dir separator */
3980             && curfullcmd[-1] != '/' && curfullcmd[-1] != '\\')
3981         {
3982             *curfullcmd++ = '\\';
3983         }
3984     }
3985
3986     Safefree(fullcmd);
3987     return Nullch;
3988 }
3989
3990 /* The following are just place holders.
3991  * Some hosts may provide and environment that the OS is
3992  * not tracking, therefore, these host must provide that
3993  * environment and the current directory to CreateProcess
3994  */
3995
3996 DllExport void*
3997 win32_get_childenv(void)
3998 {
3999     return NULL;
4000 }
4001
4002 DllExport void
4003 win32_free_childenv(void* d)
4004 {
4005 }
4006
4007 DllExport void
4008 win32_clearenv(void)
4009 {
4010     char *envv = GetEnvironmentStrings();
4011     char *cur = envv;
4012     STRLEN len;
4013     while (*cur) {
4014         char *end = strchr(cur,'=');
4015         if (end && end != cur) {
4016             *end = '\0';
4017             SetEnvironmentVariable(cur, NULL);
4018             *end = '=';
4019             cur = end + strlen(end+1)+2;
4020         }
4021         else if ((len = strlen(cur)))
4022             cur += len+1;
4023     }
4024     FreeEnvironmentStrings(envv);
4025 }
4026
4027 DllExport char*
4028 win32_get_childdir(void)
4029 {
4030     dTHX;
4031     char* ptr;
4032     char szfilename[MAX_PATH+1];
4033
4034     GetCurrentDirectoryA(MAX_PATH+1, szfilename);
4035     Newx(ptr, strlen(szfilename)+1, char);
4036     strcpy(ptr, szfilename);
4037     return ptr;
4038 }
4039
4040 DllExport void
4041 win32_free_childdir(char* d)
4042 {
4043     dTHX;
4044     Safefree(d);
4045 }
4046
4047
4048 /* XXX this needs to be made more compatible with the spawnvp()
4049  * provided by the various RTLs.  In particular, searching for
4050  * *.{com,bat,cmd} files (as done by the RTLs) is unimplemented.
4051  * This doesn't significantly affect perl itself, because we
4052  * always invoke things using PERL5SHELL if a direct attempt to
4053  * spawn the executable fails.
4054  *
4055  * XXX splitting and rejoining the commandline between do_aspawn()
4056  * and win32_spawnvp() could also be avoided.
4057  */
4058
4059 DllExport int
4060 win32_spawnvp(int mode, const char *cmdname, const char *const *argv)
4061 {
4062 #ifdef USE_RTL_SPAWNVP
4063     return spawnvp(mode, cmdname, (char * const *)argv);
4064 #else
4065     dTHX;
4066     int ret;
4067     void* env;
4068     char* dir;
4069     child_IO_table tbl;
4070     STARTUPINFO StartupInfo;
4071     PROCESS_INFORMATION ProcessInformation;
4072     DWORD create = 0;
4073     char *cmd;
4074     char *fullcmd = Nullch;
4075     char *cname = (char *)cmdname;
4076     STRLEN clen = 0;
4077
4078     if (cname) {
4079         clen = strlen(cname);
4080         /* if command name contains dquotes, must remove them */
4081         if (strchr(cname, '"')) {
4082             cmd = cname;
4083             Newx(cname,clen+1,char);
4084             clen = 0;
4085             while (*cmd) {
4086                 if (*cmd != '"') {
4087                     cname[clen] = *cmd;
4088                     ++clen;
4089                 }
4090                 ++cmd;
4091             }
4092             cname[clen] = '\0';
4093         }
4094     }
4095
4096     cmd = create_command_line(cname, clen, argv);
4097
4098     env = PerlEnv_get_childenv();
4099     dir = PerlEnv_get_childdir();
4100
4101     switch(mode) {
4102     case P_NOWAIT:      /* asynch + remember result */
4103         if (w32_num_children >= MAXIMUM_WAIT_OBJECTS) {
4104             errno = EAGAIN;
4105             ret = -1;
4106             goto RETVAL;
4107         }
4108         /* Create a new process group so we can use GenerateConsoleCtrlEvent()
4109          * in win32_kill()
4110          */
4111         create |= CREATE_NEW_PROCESS_GROUP;
4112         /* FALL THROUGH */
4113
4114     case P_WAIT:        /* synchronous execution */
4115         break;
4116     default:            /* invalid mode */
4117         errno = EINVAL;
4118         ret = -1;
4119         goto RETVAL;
4120     }
4121     memset(&StartupInfo,0,sizeof(StartupInfo));
4122     StartupInfo.cb = sizeof(StartupInfo);
4123     memset(&tbl,0,sizeof(tbl));
4124     PerlEnv_get_child_IO(&tbl);
4125     StartupInfo.dwFlags         = tbl.dwFlags;
4126     StartupInfo.dwX             = tbl.dwX;
4127     StartupInfo.dwY             = tbl.dwY;
4128     StartupInfo.dwXSize         = tbl.dwXSize;
4129     StartupInfo.dwYSize         = tbl.dwYSize;
4130     StartupInfo.dwXCountChars   = tbl.dwXCountChars;
4131     StartupInfo.dwYCountChars   = tbl.dwYCountChars;
4132     StartupInfo.dwFillAttribute = tbl.dwFillAttribute;
4133     StartupInfo.wShowWindow     = tbl.wShowWindow;
4134     StartupInfo.hStdInput       = tbl.childStdIn;
4135     StartupInfo.hStdOutput      = tbl.childStdOut;
4136     StartupInfo.hStdError       = tbl.childStdErr;
4137     if (StartupInfo.hStdInput == INVALID_HANDLE_VALUE &&
4138         StartupInfo.hStdOutput == INVALID_HANDLE_VALUE &&
4139         StartupInfo.hStdError == INVALID_HANDLE_VALUE)
4140     {
4141         create |= CREATE_NEW_CONSOLE;
4142     }
4143     else {
4144         StartupInfo.dwFlags |= STARTF_USESTDHANDLES;
4145     }
4146     if (w32_use_showwindow) {
4147         StartupInfo.dwFlags |= STARTF_USESHOWWINDOW;
4148         StartupInfo.wShowWindow = w32_showwindow;
4149     }
4150
4151     DEBUG_p(PerlIO_printf(Perl_debug_log, "Spawning [%s] with [%s]\n",
4152                           cname,cmd));
4153 RETRY:
4154     if (!CreateProcess(cname,           /* search PATH to find executable */
4155                        cmd,             /* executable, and its arguments */
4156                        NULL,            /* process attributes */
4157                        NULL,            /* thread attributes */
4158                        TRUE,            /* inherit handles */
4159                        create,          /* creation flags */
4160                        (LPVOID)env,     /* inherit environment */
4161                        dir,             /* inherit cwd */
4162                        &StartupInfo,
4163                        &ProcessInformation))
4164     {
4165         /* initial NULL argument to CreateProcess() does a PATH
4166          * search, but it always first looks in the directory
4167          * where the current process was started, which behavior
4168          * is undesirable for backward compatibility.  So we
4169          * jump through our own hoops by picking out the path
4170          * we really want it to use. */
4171         if (!fullcmd) {
4172             fullcmd = qualified_path(cname);
4173             if (fullcmd) {
4174                 if (cname != cmdname)
4175                     Safefree(cname);
4176                 cname = fullcmd;
4177                 DEBUG_p(PerlIO_printf(Perl_debug_log,
4178                                       "Retrying [%s] with same args\n",
4179                                       cname));
4180                 goto RETRY;
4181             }
4182         }
4183         errno = ENOENT;
4184         ret = -1;
4185         goto RETVAL;
4186     }
4187
4188     if (mode == P_NOWAIT) {
4189         /* asynchronous spawn -- store handle, return PID */
4190         ret = (int)ProcessInformation.dwProcessId;
4191         if (IsWin95() && ret < 0)
4192             ret = -ret;
4193
4194         w32_child_handles[w32_num_children] = ProcessInformation.hProcess;
4195         w32_child_pids[w32_num_children] = (DWORD)ret;
4196         ++w32_num_children;
4197     }
4198     else  {
4199         DWORD status;
4200         win32_msgwait(aTHX_ 1, &ProcessInformation.hProcess, INFINITE, NULL);
4201         /* FIXME: if msgwait returned due to message perhaps forward the
4202            "signal" to the process
4203          */
4204         GetExitCodeProcess(ProcessInformation.hProcess, &status);
4205         ret = (int)status;
4206         CloseHandle(ProcessInformation.hProcess);
4207     }
4208
4209     CloseHandle(ProcessInformation.hThread);
4210
4211 RETVAL:
4212     PerlEnv_free_childenv(env);
4213     PerlEnv_free_childdir(dir);
4214     Safefree(cmd);
4215     if (cname != cmdname)
4216         Safefree(cname);
4217     return ret;
4218 #endif
4219 }
4220
4221 DllExport int
4222 win32_execv(const char *cmdname, const char *const *argv)
4223 {
4224 #ifdef USE_ITHREADS
4225     dTHX;
4226     /* if this is a pseudo-forked child, we just want to spawn
4227      * the new program, and return */
4228     if (w32_pseudo_id)
4229 #  ifdef __BORLANDC__
4230         return spawnv(P_WAIT, cmdname, (char *const *)argv);
4231 #  else
4232         return spawnv(P_WAIT, cmdname, argv);
4233 #  endif
4234 #endif
4235 #ifdef __BORLANDC__
4236     return execv(cmdname, (char *const *)argv);
4237 #else
4238     return execv(cmdname, argv);
4239 #endif
4240 }
4241
4242 DllExport int
4243 win32_execvp(const char *cmdname, const char *const *argv)
4244 {
4245 #ifdef USE_ITHREADS
4246     dTHX;
4247     /* if this is a pseudo-forked child, we just want to spawn
4248      * the new program, and return */
4249     if (w32_pseudo_id) {
4250         int status = win32_spawnvp(P_WAIT, cmdname, (const char *const *)argv);
4251         if (status != -1) {
4252             my_exit(status);
4253             return 0;
4254         }
4255         else
4256             return status;
4257     }
4258 #endif
4259 #ifdef __BORLANDC__
4260     return execvp(cmdname, (char *const *)argv);
4261 #else
4262     return execvp(cmdname, argv);
4263 #endif
4264 }
4265
4266 DllExport void
4267 win32_perror(const char *str)
4268 {
4269     perror(str);
4270 }
4271
4272 DllExport void
4273 win32_setbuf(FILE *pf, char *buf)
4274 {
4275     setbuf(pf, buf);
4276 }
4277
4278 DllExport int
4279 win32_setvbuf(FILE *pf, char *buf, int type, size_t size)
4280 {
4281     return setvbuf(pf, buf, type, size);
4282 }
4283
4284 DllExport int
4285 win32_flushall(void)
4286 {
4287     return flushall();
4288 }
4289
4290 DllExport int
4291 win32_fcloseall(void)
4292 {
4293     return fcloseall();
4294 }
4295
4296 DllExport char*
4297 win32_fgets(char *s, int n, FILE *pf)
4298 {
4299     return fgets(s, n, pf);
4300 }
4301
4302 DllExport char*
4303 win32_gets(char *s)
4304 {
4305     return gets(s);
4306 }
4307
4308 DllExport int
4309 win32_fgetc(FILE *pf)
4310 {
4311     return fgetc(pf);
4312 }
4313
4314 DllExport int
4315 win32_putc(int c, FILE *pf)
4316 {
4317     return putc(c,pf);
4318 }
4319
4320 DllExport int
4321 win32_puts(const char *s)
4322 {
4323     return puts(s);
4324 }
4325
4326 DllExport int
4327 win32_getchar(void)
4328 {
4329     return getchar();
4330 }
4331
4332 DllExport int
4333 win32_putchar(int c)
4334 {
4335     return putchar(c);
4336 }
4337
4338 #ifdef MYMALLOC
4339
4340 #ifndef USE_PERL_SBRK
4341
4342 static char *committed = NULL;          /* XXX threadead */
4343 static char *base      = NULL;          /* XXX threadead */
4344 static char *reserved  = NULL;          /* XXX threadead */
4345 static char *brk       = NULL;          /* XXX threadead */
4346 static DWORD pagesize  = 0;             /* XXX threadead */
4347
4348 void *
4349 sbrk(ptrdiff_t need)
4350 {
4351  void *result;
4352  if (!pagesize)
4353   {SYSTEM_INFO info;
4354    GetSystemInfo(&info);
4355    /* Pretend page size is larger so we don't perpetually
4356     * call the OS to commit just one page ...
4357     */
4358    pagesize = info.dwPageSize << 3;
4359   }
4360  if (brk+need >= reserved)
4361   {
4362    DWORD size = brk+need-reserved;
4363    char *addr;
4364    char *prev_committed = NULL;
4365    if (committed && reserved && committed < reserved)
4366     {
4367      /* Commit last of previous chunk cannot span allocations */
4368      addr = (char *) VirtualAlloc(committed,reserved-committed,MEM_COMMIT,PAGE_READWRITE);
4369      if (addr)
4370       {
4371       /* Remember where we committed from in case we want to decommit later */
4372       prev_committed = committed;
4373       committed = reserved;
4374       }
4375     }
4376    /* Reserve some (more) space
4377     * Contiguous blocks give us greater efficiency, so reserve big blocks -
4378     * this is only address space not memory...
4379     * Note this is a little sneaky, 1st call passes NULL as reserved
4380     * so lets system choose where we start, subsequent calls pass
4381     * the old end address so ask for a contiguous block
4382     */
4383 sbrk_reserve:
4384    if (size < 64*1024*1024)
4385     size = 64*1024*1024;
4386    size = ((size + pagesize - 1) / pagesize) * pagesize;
4387    addr  = (char *) VirtualAlloc(reserved,size,MEM_RESERVE,PAGE_NOACCESS);
4388    if (addr)
4389     {
4390      reserved = addr+size;
4391      if (!base)
4392       base = addr;
4393      if (!committed)
4394       committed = base;
4395      if (!brk)
4396       brk = committed;
4397     }
4398    else if (reserved)
4399     {
4400       /* The existing block could not be extended far enough, so decommit
4401        * anything that was just committed above and start anew */
4402       if (prev_committed)
4403        {
4404        if (!VirtualFree(prev_committed,reserved-prev_committed,MEM_DECOMMIT))
4405         return (void *) -1;
4406        }
4407       reserved = base = committed = brk = NULL;
4408       size = need;
4409       goto sbrk_reserve;
4410     }
4411    else
4412     {
4413      return (void *) -1;
4414     }
4415   }
4416  result = brk;
4417  brk += need;
4418  if (brk > committed)
4419   {
4420    DWORD size = ((brk-committed + pagesize -1)/pagesize) * pagesize;
4421    char *addr;
4422    if (committed+size > reserved)
4423     size = reserved-committed;
4424    addr = (char *) VirtualAlloc(committed,size,MEM_COMMIT,PAGE_READWRITE);
4425    if (addr)
4426     committed += size;
4427    else
4428     return (void *) -1;
4429   }
4430  return result;
4431 }
4432
4433 #endif
4434 #endif
4435
4436 DllExport void*
4437 win32_malloc(size_t size)
4438 {
4439     return malloc(size);
4440 }
4441
4442 DllExport void*
4443 win32_calloc(size_t numitems, size_t size)
4444 {
4445     return calloc(numitems,size);
4446 }
4447
4448 DllExport void*
4449 win32_realloc(void *block, size_t size)
4450 {
4451     return realloc(block,size);
4452 }
4453
4454 DllExport void
4455 win32_free(void *block)
4456 {
4457     free(block);
4458 }
4459
4460
4461 DllExport int
4462 win32_open_osfhandle(intptr_t handle, int flags)
4463 {
4464 #ifdef USE_FIXED_OSFHANDLE
4465     if (IsWin95())
4466         return my_open_osfhandle(handle, flags);
4467 #endif
4468     return _open_osfhandle(handle, flags);
4469 }
4470
4471 DllExport intptr_t
4472 win32_get_osfhandle(int fd)
4473 {
4474     return (intptr_t)_get_osfhandle(fd);
4475 }
4476
4477 DllExport FILE *
4478 win32_fdupopen(FILE *pf)
4479 {
4480     FILE* pfdup;
4481     fpos_t pos;
4482     char mode[3];
4483     int fileno = win32_dup(win32_fileno(pf));
4484
4485     /* open the file in the same mode */
4486 #ifdef __BORLANDC__
4487     if((pf)->flags & _F_READ) {
4488         mode[0] = 'r';
4489         mode[1] = 0;
4490     }
4491     else if((pf)->flags & _F_WRIT) {
4492         mode[0] = 'a';
4493         mode[1] = 0;
4494     }
4495     else if((pf)->flags & _F_RDWR) {
4496         mode[0] = 'r';
4497         mode[1] = '+';
4498         mode[2] = 0;
4499     }
4500 #else
4501     if((pf)->_flag & _IOREAD) {
4502         mode[0] = 'r';
4503         mode[1] = 0;
4504     }
4505     else if((pf)->_flag & _IOWRT) {
4506         mode[0] = 'a';
4507         mode[1] = 0;
4508     }
4509     else if((pf)->_flag & _IORW) {
4510         mode[0] = 'r';
4511         mode[1] = '+';
4512         mode[2] = 0;
4513     }
4514 #endif
4515
4516     /* it appears that the binmode is attached to the
4517      * file descriptor so binmode files will be handled
4518      * correctly
4519      */
4520     pfdup = win32_fdopen(fileno, mode);
4521
4522     /* move the file pointer to the same position */
4523     if (!fgetpos(pf, &pos)) {
4524         fsetpos(pfdup, &pos);
4525     }
4526     return pfdup;
4527 }
4528
4529 DllExport void*
4530 win32_dynaload(const char* filename)
4531 {
4532     dTHX;
4533     char buf[MAX_PATH+1];
4534     char *first;
4535
4536     /* LoadLibrary() doesn't recognize forward slashes correctly,
4537      * so turn 'em back. */
4538     first = strchr(filename, '/');
4539     if (first) {
4540         STRLEN len = strlen(filename);
4541         if (len <= MAX_PATH) {
4542             strcpy(buf, filename);
4543             filename = &buf[first - filename];
4544             while (*filename) {
4545                 if (*filename == '/')
4546                     *(char*)filename = '\\';
4547                 ++filename;
4548             }
4549             filename = buf;
4550         }
4551     }
4552     return LoadLibraryExA(PerlDir_mapA(filename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
4553 }
4554
4555 XS(w32_SetChildShowWindow)
4556 {
4557     dXSARGS;
4558     BOOL use_showwindow = w32_use_showwindow;
4559     /* use "unsigned short" because Perl has redefined "WORD" */
4560     unsigned short showwindow = w32_showwindow;
4561
4562     if (items > 1)
4563         Perl_croak(aTHX_ "usage: Win32::SetChildShowWindow($showwindow)");
4564
4565     if (items == 0 || !SvOK(ST(0)))
4566         w32_use_showwindow = FALSE;
4567     else {
4568         w32_use_showwindow = TRUE;
4569         w32_showwindow = (unsigned short)SvIV(ST(0));
4570     }
4571
4572     EXTEND(SP, 1);
4573     if (use_showwindow)
4574         ST(0) = sv_2mortal(newSViv(showwindow));
4575     else
4576         ST(0) = &PL_sv_undef;
4577     XSRETURN(1);
4578 }
4579
4580 void
4581 Perl_init_os_extras(void)
4582 {
4583     dTHX;
4584     char *file = __FILE__;
4585     CV *cv;
4586     dXSUB_SYS;
4587
4588     /* load Win32 CORE stubs, assuming Win32CORE was statically linked */
4589     if ((cv = get_cv("Win32CORE::bootstrap", 0))) {
4590         dSP;
4591         PUSHMARK(SP);
4592         (void)call_sv((SV *)cv, G_EVAL|G_DISCARD|G_VOID);
4593     }
4594
4595     newXS("Win32::SetChildShowWindow", w32_SetChildShowWindow, file);
4596 }
4597
4598 void *
4599 win32_signal_context(void)
4600 {
4601     dTHX;
4602 #ifdef MULTIPLICITY
4603     if (!my_perl) {
4604         my_perl = PL_curinterp;
4605         PERL_SET_THX(my_perl);
4606     }
4607     return my_perl;
4608 #else
4609     return PL_curinterp;
4610 #endif
4611 }
4612
4613
4614 BOOL WINAPI
4615 win32_ctrlhandler(DWORD dwCtrlType)
4616 {
4617 #ifdef MULTIPLICITY
4618     dTHXa(PERL_GET_SIG_CONTEXT);
4619
4620     if (!my_perl)
4621         return FALSE;
4622 #endif
4623
4624     switch(dwCtrlType) {
4625     case CTRL_CLOSE_EVENT:
4626      /*  A signal that the system sends to all processes attached to a console when
4627          the user closes the console (either by choosing the Close command from the
4628          console window's System menu, or by choosing the End Task command from the
4629          Task List
4630       */
4631         if (do_raise(aTHX_ 1))        /* SIGHUP */
4632             sig_terminate(aTHX_ 1);
4633         return TRUE;
4634
4635     case CTRL_C_EVENT:
4636         /*  A CTRL+c signal was received */
4637         if (do_raise(aTHX_ SIGINT))
4638             sig_terminate(aTHX_ SIGINT);
4639         return TRUE;
4640
4641     case CTRL_BREAK_EVENT:
4642         /*  A CTRL+BREAK signal was received */
4643         if (do_raise(aTHX_ SIGBREAK))
4644             sig_terminate(aTHX_ SIGBREAK);
4645         return TRUE;
4646
4647     case CTRL_LOGOFF_EVENT:
4648       /*  A signal that the system sends to all console processes when a user is logging
4649           off. This signal does not indicate which user is logging off, so no
4650           assumptions can be made.
4651        */
4652         break;
4653     case CTRL_SHUTDOWN_EVENT:
4654       /*  A signal that the system sends to all console processes when the system is
4655           shutting down.
4656        */
4657         if (do_raise(aTHX_ SIGTERM))
4658             sig_terminate(aTHX_ SIGTERM);
4659         return TRUE;
4660     default:
4661         break;
4662     }
4663     return FALSE;
4664 }
4665
4666
4667 #ifdef SET_INVALID_PARAMETER_HANDLER
4668 #  include <crtdbg.h>
4669 #endif
4670
4671 static void
4672 ansify_path(void)
4673 {
4674     size_t len;
4675     char *ansi_path;
4676     WCHAR *wide_path;
4677     WCHAR *wide_dir;
4678
4679     /* there is no Unicode environment on Windows 9X */
4680     if (IsWin95())
4681         return;
4682
4683     /* fetch Unicode version of PATH */
4684     len = 2000;
4685     wide_path = win32_malloc(len*sizeof(WCHAR));
4686     while (wide_path) {
4687         size_t newlen = GetEnvironmentVariableW(L"PATH", wide_path, len);
4688         if (newlen < len)
4689             break;
4690         len = newlen;
4691         wide_path = win32_realloc(wide_path, len*sizeof(WCHAR));
4692     }
4693     if (!wide_path)
4694         return;
4695
4696     /* convert to ANSI pathnames */
4697     wide_dir = wide_path;
4698     ansi_path = NULL;
4699     while (wide_dir) {
4700         WCHAR *sep = wcschr(wide_dir, ';');
4701         char *ansi_dir;
4702         size_t ansi_len;
4703         size_t wide_len;
4704
4705         if (sep)
4706             *sep++ = '\0';
4707
4708         /* remove quotes around pathname */
4709         if (*wide_dir == '"')
4710             ++wide_dir;
4711         wide_len = wcslen(wide_dir);
4712         if (wide_len && wide_dir[wide_len-1] == '"')
4713             wide_dir[wide_len-1] = '\0';
4714
4715         /* append ansi_dir to ansi_path */
4716         ansi_dir = win32_ansipath(wide_dir);
4717         ansi_len = strlen(ansi_dir);
4718         if (ansi_path) {
4719             size_t newlen = len + 1 + ansi_len;
4720             ansi_path = win32_realloc(ansi_path, newlen+1);
4721             if (!ansi_path)
4722                 break;
4723             ansi_path[len] = ';';
4724             memcpy(ansi_path+len+1, ansi_dir, ansi_len+1);
4725             len = newlen;
4726         }
4727         else {
4728             len = ansi_len;
4729             ansi_path = win32_malloc(5+len+1);
4730             if (!ansi_path)
4731                 break;
4732             memcpy(ansi_path, "PATH=", 5);
4733             memcpy(ansi_path+5, ansi_dir, len+1);
4734             len += 5;
4735         }
4736         win32_free(ansi_dir);
4737         wide_dir = sep;
4738     }
4739
4740     if (ansi_path) {
4741         /* Update C RTL environ array.  This will only have full effect if
4742          * perl_parse() is later called with `environ` as the `env` argument.
4743          * Otherwise S_init_postdump_symbols() will overwrite PATH again.
4744          *
4745          * We do have to ansify() the PATH before Perl has been fully
4746          * initialized because S_find_script() uses the PATH when perl
4747          * is being invoked with the -S option.  This happens before %ENV
4748          * is initialized in S_init_postdump_symbols().
4749          *
4750          * XXX Is this a bug? Should S_find_script() use the environment
4751          * XXX passed in the `env` arg to parse_perl()?
4752          */
4753         putenv(ansi_path);
4754         /* Keep system environment in sync because S_init_postdump_symbols()
4755          * will not call mg_set() if it initializes %ENV from `environ`.
4756          */
4757         SetEnvironmentVariableA("PATH", ansi_path+5);
4758         /* We are intentionally leaking the ansi_path string here because
4759          * the Borland runtime library puts it directly into the environ
4760          * array.  The Microsoft runtime library seems to make a copy,
4761          * but will leak the copy should it be replaced again later.
4762          * Since this code is only called once during PERL_SYS_INIT this
4763          * shouldn't really matter.
4764          */
4765     }
4766     win32_free(wide_path);
4767 }
4768
4769 void
4770 Perl_win32_init(int *argcp, char ***argvp)
4771 {
4772     HMODULE module;
4773
4774 #ifdef SET_INVALID_PARAMETER_HANDLER
4775     _invalid_parameter_handler oldHandler, newHandler;
4776     newHandler = my_invalid_parameter_handler;
4777     oldHandler = _set_invalid_parameter_handler(newHandler);
4778     _CrtSetReportMode(_CRT_ASSERT, 0);
4779 #endif
4780     /* Disable floating point errors, Perl will trap the ones we
4781      * care about.  VC++ RTL defaults to switching these off
4782      * already, but the Borland RTL doesn't.  Since we don't
4783      * want to be at the vendor's whim on the default, we set
4784      * it explicitly here.
4785      */
4786 #if !defined(_ALPHA_) && !defined(__GNUC__)
4787     _control87(MCW_EM, MCW_EM);
4788 #endif
4789     MALLOC_INIT;
4790
4791     module = GetModuleHandle("ntdll.dll");
4792     if (module) {
4793         *(FARPROC*)&pfnZwQuerySystemInformation = GetProcAddress(module, "ZwQuerySystemInformation");
4794     }
4795
4796     module = GetModuleHandle("kernel32.dll");
4797     if (module) {
4798         *(FARPROC*)&pfnCreateToolhelp32Snapshot = GetProcAddress(module, "CreateToolhelp32Snapshot");
4799         *(FARPROC*)&pfnProcess32First           = GetProcAddress(module, "Process32First");
4800         *(FARPROC*)&pfnProcess32Next            = GetProcAddress(module, "Process32Next");
4801     }
4802
4803     g_osver.dwOSVersionInfoSize = sizeof(g_osver);
4804     GetVersionEx(&g_osver);
4805
4806     ansify_path();
4807 }
4808
4809 void
4810 Perl_win32_term(void)
4811 {
4812     dTHX;
4813     HINTS_REFCNT_TERM;
4814     OP_REFCNT_TERM;
4815     PERLIO_TERM;
4816     MALLOC_TERM;
4817 }
4818
4819 void
4820 win32_get_child_IO(child_IO_table* ptbl)
4821 {
4822     ptbl->childStdIn    = GetStdHandle(STD_INPUT_HANDLE);
4823     ptbl->childStdOut   = GetStdHandle(STD_OUTPUT_HANDLE);
4824     ptbl->childStdErr   = GetStdHandle(STD_ERROR_HANDLE);
4825 }
4826
4827 Sighandler_t
4828 win32_signal(int sig, Sighandler_t subcode)
4829 {
4830     dTHX;
4831     if (sig < SIG_SIZE) {
4832         int save_errno = errno;
4833         Sighandler_t result = signal(sig, subcode);
4834         if (result == SIG_ERR) {