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