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