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