This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Upgrade to Encode 1.52, from Dan Kogai.
[perl5.git] / win32 / win32.c
CommitLineData
68dc0745
PP
1/* WIN32.C
2 *
3fadfdf1 3 * (c) 1995 Microsoft Corporation. All rights reserved.
68dc0745
PP
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 */
3fadfdf1 10#define PERLIO_NOT_STDIO 0
0a753a76
PP
11#define WIN32_LEAN_AND_MEAN
12#define WIN32IO_IS_STDIO
13#include <tchar.h>
a835ef8a
NIS
14#ifdef __GNUC__
15#define Win32_Winsock
16#endif
0a753a76 17#include <windows.h>
f8fb7c90
GS
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
5db10396
GS
23#include <winnt.h>
24#include <io.h>
c843839f 25#include <signal.h>
0a753a76 26
68dc0745 27/* #include "config.h" */
0a753a76 28
0a753a76
PP
29#if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
30#define PerlIO FILE
31#endif
32
7a9ec5a3 33#include <sys/stat.h>
0a753a76
PP
34#include "EXTERN.h"
35#include "perl.h"
c69f6586
GS
36
37#define NO_XSLOCKS
c5be433b 38#define PERL_NO_GET_CONTEXT
ad2e33dc 39#include "XSUB.h"
c69f6586
GS
40
41#include "Win32iop.h"
0a753a76 42#include <fcntl.h>
5b0d9cbe
NIS
43#ifndef __GNUC__
44/* assert.h conflicts with #define of assert in perl.h */
0a753a76 45#include <assert.h>
5b0d9cbe 46#endif
0a753a76
PP
47#include <string.h>
48#include <stdarg.h>
ad2e33dc 49#include <float.h>
ad0751ec 50#include <time.h>
3730b96e 51#if defined(_MSC_VER) || defined(__MINGW32__)
ad0751ec
GS
52#include <sys/utime.h>
53#else
54#include <utime.h>
55#endif
5b0d9cbe 56#ifdef __GNUC__
3fadfdf1 57/* Mingw32 defaults to globing command line
5b0d9cbe
NIS
58 * So we turn it off like this:
59 */
60int _CRT_glob = 0;
61#endif
62
2b260de0 63#if defined(__MINGW32__)
f8fb7c90
GS
64/* Mingw32 is missing some prototypes */
65FILE * _wfopen(LPCWSTR wszFileName, LPCWSTR wszMode);
66FILE * _wfdopen(int nFd, LPCWSTR wszMode);
67FILE * _freopen(LPCWSTR wszFileName, LPCWSTR wszMode, FILE * pOldStream);
68int _flushall();
69int _fcloseall();
2b260de0
GS
70#endif
71
72#if defined(__BORLANDC__)
0b94c7bb
GS
73# define _stat stat
74# define _utimbuf utimbuf
75#endif
76
6890e559
GS
77#define EXECF_EXEC 1
78#define EXECF_SPAWN 2
79#define EXECF_SPAWN_NOWAIT 3
80
32e30700
GS
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
4ea817c6
GS
86# undef win32_get_vendorlib
87# define win32_get_vendorlib g_win32_get_vendorlib
32e30700
GS
88# undef do_spawn
89# define do_spawn g_do_spawn
90# undef getlogin
91# define getlogin g_getlogin
92#endif
93
ce1da67e 94static void get_shell(void);
dff6d3cd 95static long tokenize(const char *str, char **dest, char ***destv);
c5be433b 96 int do_spawn2(char *cmd, int exectype);
e200fe59 97static BOOL has_shell_metachars(char *ptr);
2d7a9237 98static long filetime_to_clock(PFILETIME ft);
ad0751ec 99static BOOL filetime_from_time(PFILETIME ft, time_t t);
c5be433b 100static char * get_emd_part(SV **leading, char *trailing, ...);
0aaad0ff
GS
101static void remove_dead_process(long deceased);
102static long find_pid(int pid);
103static char * qualified_path(const char *cmd);
4ea817c6
GS
104static char * win32_get_xlib(const char *pl, const char *xlib,
105 const char *libname);
106
7766f137
GS
107#ifdef USE_ITHREADS
108static void remove_dead_pseudo_process(long child);
109static long find_pseudo_pid(int pid);
110#endif
c69f6586 111
7766f137 112START_EXTERN_C
2d7a9237 113HANDLE w32_perldll_handle = INVALID_HANDLE_VALUE;
8ac9c18d 114char w32_module_name[MAX_PATH+1];
7766f137
GS
115END_EXTERN_C
116
4b556e6c 117static DWORD w32_platform = (DWORD)-1;
50892819 118
7766f137
GS
119#define ONE_K_BUFSIZE 1024
120
3fadfdf1 121int
ba106d47
GS
122IsWin95(void)
123{
0cb96387 124 return (win32_os_id() == VER_PLATFORM_WIN32_WINDOWS);
3fe9a6f1
PP
125}
126
127int
ba106d47
GS
128IsWinNT(void)
129{
0cb96387 130 return (win32_os_id() == VER_PLATFORM_WIN32_NT);
3fe9a6f1 131}
0a753a76 132
2fa86c13
GS
133EXTERN_C void
134set_w32_module_name(void)
135{
136 char* ptr;
137 GetModuleFileName((HMODULE)((w32_perldll_handle == INVALID_HANDLE_VALUE)
138 ? GetModuleHandle(NULL)
139 : w32_perldll_handle),
140 w32_module_name, sizeof(w32_module_name));
141
142 /* try to get full path to binary (which may be mangled when perl is
143 * run from a 16-bit app) */
144 /*PerlIO_printf(Perl_debug_log, "Before %s\n", w32_module_name);*/
145 (void)win32_longpath(w32_module_name);
146 /*PerlIO_printf(Perl_debug_log, "After %s\n", w32_module_name);*/
147
148 /* normalize to forward slashes */
149 ptr = w32_module_name;
150 while (*ptr) {
151 if (*ptr == '\\')
152 *ptr = '/';
153 ++ptr;
154 }
155}
156
c5be433b 157/* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
51371543 158static char*
c5be433b 159get_regstr_from(HKEY hkey, const char *valuename, SV **svp)
349ad1fe
GS
160{
161 /* Retrieve a REG_SZ or REG_EXPAND_SZ from the registry */
00dc2f4f
GS
162 HKEY handle;
163 DWORD type;
164 const char *subkey = "Software\\Perl";
349ad1fe 165 char *str = Nullch;
00dc2f4f
GS
166 long retval;
167
168 retval = RegOpenKeyEx(hkey, subkey, 0, KEY_READ, &handle);
349ad1fe 169 if (retval == ERROR_SUCCESS) {
51371543
GS
170 DWORD datalen;
171 retval = RegQueryValueEx(handle, valuename, 0, &type, NULL, &datalen);
1c94caf4
GS
172 if (retval == ERROR_SUCCESS
173 && (type == REG_SZ || type == REG_EXPAND_SZ))
174 {
acfe0abc 175 dTHX;
c5be433b
GS
176 if (!*svp)
177 *svp = sv_2mortal(newSVpvn("",0));
178 SvGROW(*svp, datalen);
51371543 179 retval = RegQueryValueEx(handle, valuename, 0, NULL,
c5be433b 180 (PBYTE)SvPVX(*svp), &datalen);
51371543 181 if (retval == ERROR_SUCCESS) {
c5be433b
GS
182 str = SvPVX(*svp);
183 SvCUR_set(*svp,datalen-1);
51371543 184 }
00dc2f4f
GS
185 }
186 RegCloseKey(handle);
187 }
349ad1fe 188 return str;
00dc2f4f
GS
189}
190
c5be433b 191/* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
51371543 192static char*
c5be433b 193get_regstr(const char *valuename, SV **svp)
00dc2f4f 194{
c5be433b 195 char *str = get_regstr_from(HKEY_CURRENT_USER, valuename, svp);
349ad1fe 196 if (!str)
c5be433b 197 str = get_regstr_from(HKEY_LOCAL_MACHINE, valuename, svp);
349ad1fe 198 return str;
00dc2f4f
GS
199}
200
c5be433b 201/* *prev_pathp (if non-NULL) is expected to be POK (valid allocated SvPVX(sv)) */
e5a95ffb 202static char *
c5be433b 203get_emd_part(SV **prev_pathp, char *trailing_path, ...)
00dc2f4f 204{
dc9e4912 205 char base[10];
e5a95ffb 206 va_list ap;
e24c7c18 207 char mod_name[MAX_PATH+1];
00dc2f4f 208 char *ptr;
e5a95ffb
GS
209 char *optr;
210 char *strip;
211 int oldsize, newsize;
273cf8d1 212 STRLEN baselen;
e5a95ffb
GS
213
214 va_start(ap, trailing_path);
215 strip = va_arg(ap, char *);
216
273cf8d1
GS
217 sprintf(base, "%d.%d", (int)PERL_REVISION, (int)PERL_VERSION);
218 baselen = strlen(base);
dc9e4912 219
8ac9c18d 220 if (!*w32_module_name) {
2fa86c13 221 set_w32_module_name();
95140b98 222 }
8ac9c18d 223 strcpy(mod_name, w32_module_name);
95140b98 224 ptr = strrchr(mod_name, '/');
e5a95ffb
GS
225 while (ptr && strip) {
226 /* look for directories to skip back */
227 optr = ptr;
00dc2f4f 228 *ptr = '\0';
95140b98 229 ptr = strrchr(mod_name, '/');
1c39adb2
GS
230 /* avoid stripping component if there is no slash,
231 * or it doesn't match ... */
e5a95ffb 232 if (!ptr || stricmp(ptr+1, strip) != 0) {
273cf8d1 233 /* ... but not if component matches m|5\.$patchlevel.*| */
1c39adb2 234 if (!ptr || !(*strip == '5' && *(ptr+1) == '5'
273cf8d1
GS
235 && strncmp(strip, base, baselen) == 0
236 && strncmp(ptr+1, base, baselen) == 0))
95140b98
GS
237 {
238 *optr = '/';
80252599
GS
239 ptr = optr;
240 }
00dc2f4f 241 }
e5a95ffb 242 strip = va_arg(ap, char *);
00dc2f4f 243 }
e5a95ffb
GS
244 if (!ptr) {
245 ptr = mod_name;
246 *ptr++ = '.';
95140b98 247 *ptr = '/';
00dc2f4f 248 }
e5a95ffb
GS
249 va_end(ap);
250 strcpy(++ptr, trailing_path);
251
dc9e4912 252 /* only add directory if it exists */
349ad1fe 253 if (GetFileAttributes(mod_name) != (DWORD) -1) {
dc9e4912 254 /* directory exists */
acfe0abc 255 dTHX;
c5be433b
GS
256 if (!*prev_pathp)
257 *prev_pathp = sv_2mortal(newSVpvn("",0));
258 sv_catpvn(*prev_pathp, ";", 1);
259 sv_catpv(*prev_pathp, mod_name);
260 return SvPVX(*prev_pathp);
00dc2f4f 261 }
00dc2f4f 262
cf11f4bf 263 return Nullch;
00dc2f4f
GS
264}
265
266char *
4ea817c6 267win32_get_privlib(const char *pl)
00dc2f4f 268{
acfe0abc 269 dTHX;
e5a95ffb
GS
270 char *stdlib = "lib";
271 char buffer[MAX_PATH+1];
51371543 272 SV *sv = Nullsv;
00dc2f4f 273
e5a95ffb
GS
274 /* $stdlib = $HKCU{"lib-$]"} || $HKLM{"lib-$]"} || $HKCU{"lib"} || $HKLM{"lib"} || ""; */
275 sprintf(buffer, "%s-%s", stdlib, pl);
c5be433b
GS
276 if (!get_regstr(buffer, &sv))
277 (void)get_regstr(stdlib, &sv);
00dc2f4f 278
e5a95ffb 279 /* $stdlib .= ";$EMD/../../lib" */
c5be433b 280 return get_emd_part(&sv, stdlib, ARCHNAME, "bin", Nullch);
00dc2f4f
GS
281}
282
4ea817c6
GS
283static char *
284win32_get_xlib(const char *pl, const char *xlib, const char *libname)
00dc2f4f 285{
acfe0abc 286 dTHX;
e5a95ffb 287 char regstr[40];
e24c7c18 288 char pathstr[MAX_PATH+1];
e5a95ffb 289 DWORD datalen;
e5a95ffb 290 int len, newsize;
51371543
GS
291 SV *sv1 = Nullsv;
292 SV *sv2 = Nullsv;
00dc2f4f 293
4ea817c6
GS
294 /* $HKCU{"$xlib-$]"} || $HKLM{"$xlib-$]"} . ---; */
295 sprintf(regstr, "%s-%s", xlib, pl);
c5be433b 296 (void)get_regstr(regstr, &sv1);
e5a95ffb 297
4ea817c6
GS
298 /* $xlib .=
299 * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/$]/lib"; */
300 sprintf(pathstr, "%s/%s/lib", libname, pl);
c5be433b 301 (void)get_emd_part(&sv1, pathstr, ARCHNAME, "bin", pl, Nullch);
00dc2f4f 302
4ea817c6
GS
303 /* $HKCU{$xlib} || $HKLM{$xlib} . ---; */
304 (void)get_regstr(xlib, &sv2);
00dc2f4f 305
4ea817c6
GS
306 /* $xlib .=
307 * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/lib"; */
308 sprintf(pathstr, "%s/lib", libname);
309 (void)get_emd_part(&sv2, pathstr, ARCHNAME, "bin", pl, Nullch);
e5a95ffb 310
51371543
GS
311 if (!sv1 && !sv2)
312 return Nullch;
313 if (!sv1)
314 return SvPVX(sv2);
315 if (!sv2)
316 return SvPVX(sv1);
e5a95ffb 317
349ad1fe
GS
318 sv_catpvn(sv1, ";", 1);
319 sv_catsv(sv1, sv2);
e5a95ffb 320
349ad1fe 321 return SvPVX(sv1);
68dc0745 322}
0a753a76 323
4ea817c6
GS
324char *
325win32_get_sitelib(const char *pl)
326{
327 return win32_get_xlib(pl, "sitelib", "site");
328}
329
330#ifndef PERL_VENDORLIB_NAME
331# define PERL_VENDORLIB_NAME "vendor"
332#endif
333
334char *
335win32_get_vendorlib(const char *pl)
336{
337 return win32_get_xlib(pl, "vendorlib", PERL_VENDORLIB_NAME);
338}
b4793f7f 339
2d7a9237 340static BOOL
e200fe59 341has_shell_metachars(char *ptr)
68dc0745
PP
342{
343 int inquote = 0;
344 char quote = '\0';
345
346 /*
347 * Scan string looking for redirection (< or >) or pipe
e200fe59
JD
348 * characters (|) that are not in a quoted string.
349 * Shell variable interpolation (%VAR%) can also happen inside strings.
68dc0745 350 */
9404a519 351 while (*ptr) {
68dc0745 352 switch(*ptr) {
e200fe59
JD
353 case '%':
354 return TRUE;
68dc0745
PP
355 case '\'':
356 case '\"':
9404a519
GS
357 if (inquote) {
358 if (quote == *ptr) {
68dc0745
PP
359 inquote = 0;
360 quote = '\0';
0a753a76 361 }
68dc0745
PP
362 }
363 else {
364 quote = *ptr;
365 inquote++;
366 }
367 break;
368 case '>':
369 case '<':
370 case '|':
9404a519 371 if (!inquote)
68dc0745
PP
372 return TRUE;
373 default:
374 break;
0a753a76 375 }
68dc0745
PP
376 ++ptr;
377 }
378 return FALSE;
0a753a76
PP
379}
380
32e30700 381#if !defined(PERL_IMPLICIT_SYS)
68dc0745
PP
382/* since the current process environment is being updated in util.c
383 * the library functions will get the correct environment
384 */
385PerlIO *
4f63d024 386Perl_my_popen(pTHX_ char *cmd, char *mode)
0a753a76
PP
387{
388#ifdef FIXCMD
7766f137
GS
389#define fixcmd(x) { \
390 char *pspace = strchr((x),' '); \
391 if (pspace) { \
392 char *p = (x); \
393 while (p < pspace) { \
394 if (*p == '/') \
395 *p = '\\'; \
396 p++; \
397 } \
398 } \
399 }
0a753a76
PP
400#else
401#define fixcmd(x)
402#endif
68dc0745 403 fixcmd(cmd);
45bc9206 404 PERL_FLUSHALL_FOR_CHILD;
0a753a76 405 return win32_popen(cmd, mode);
0a753a76
PP
406}
407
68dc0745 408long
4f63d024 409Perl_my_pclose(pTHX_ PerlIO *fp)
0a753a76
PP
410{
411 return win32_pclose(fp);
412}
c69f6586 413#endif
0a753a76 414
0cb96387
GS
415DllExport unsigned long
416win32_os_id(void)
0a753a76 417{
8b10511d 418 static OSVERSIONINFO osver;
0a753a76 419
2d7a9237 420 if (osver.dwPlatformId != w32_platform) {
8b10511d
GS
421 memset(&osver, 0, sizeof(OSVERSIONINFO));
422 osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
423 GetVersionEx(&osver);
2d7a9237 424 w32_platform = osver.dwPlatformId;
8b10511d 425 }
0cb96387 426 return (unsigned long)w32_platform;
0a753a76
PP
427}
428
7766f137
GS
429DllExport int
430win32_getpid(void)
431{
922b1888 432 int pid;
7766f137 433#ifdef USE_ITHREADS
acfe0abc 434 dTHX;
7766f137
GS
435 if (w32_pseudo_id)
436 return -((int)w32_pseudo_id);
437#endif
922b1888
GS
438 pid = _getpid();
439 /* Windows 9x appears to always reports a pid for threads and processes
440 * that has the high bit set. So we treat the lower 31 bits as the
441 * "real" PID for Perl's purposes. */
442 if (IsWin95() && pid < 0)
443 pid = -pid;
444 return pid;
7766f137
GS
445}
446
ce1da67e
GS
447/* Tokenize a string. Words are null-separated, and the list
448 * ends with a doubled null. Any character (except null and
449 * including backslash) may be escaped by preceding it with a
450 * backslash (the backslash will be stripped).
451 * Returns number of words in result buffer.
452 */
453static long
dff6d3cd 454tokenize(const char *str, char **dest, char ***destv)
ce1da67e
GS
455{
456 char *retstart = Nullch;
457 char **retvstart = 0;
458 int items = -1;
459 if (str) {
acfe0abc 460 dTHX;
ce1da67e
GS
461 int slen = strlen(str);
462 register char *ret;
463 register char **retv;
464 New(1307, ret, slen+2, char);
465 New(1308, retv, (slen+3)/2, char*);
466
467 retstart = ret;
468 retvstart = retv;
469 *retv = ret;
470 items = 0;
471 while (*str) {
472 *ret = *str++;
473 if (*ret == '\\' && *str)
474 *ret = *str++;
475 else if (*ret == ' ') {
476 while (*str == ' ')
477 str++;
478 if (ret == retstart)
479 ret--;
480 else {
481 *ret = '\0';
482 ++items;
483 if (*str)
484 *++retv = ret+1;
485 }
486 }
487 else if (!*str)
488 ++items;
489 ret++;
490 }
491 retvstart[items] = Nullch;
492 *ret++ = '\0';
493 *ret = '\0';
494 }
495 *dest = retstart;
496 *destv = retvstart;
497 return items;
498}
499
500static void
2d7a9237 501get_shell(void)
0a753a76 502{
acfe0abc 503 dTHX;
ce1da67e 504 if (!w32_perlshell_tokens) {
174c211a
GS
505 /* we don't use COMSPEC here for two reasons:
506 * 1. the same reason perl on UNIX doesn't use SHELL--rampant and
507 * uncontrolled unportability of the ensuing scripts.
508 * 2. PERL5SHELL could be set to a shell that may not be fit for
509 * interactive use (which is what most programs look in COMSPEC
510 * for).
511 */
dff6d3cd
GS
512 const char* defaultshell = (IsWinNT()
513 ? "cmd.exe /x/c" : "command.com /c");
2fb9ab56 514 const char *usershell = PerlEnv_getenv("PERL5SHELL");
ce1da67e
GS
515 w32_perlshell_items = tokenize(usershell ? usershell : defaultshell,
516 &w32_perlshell_tokens,
517 &w32_perlshell_vec);
68dc0745 518 }
0a753a76
PP
519}
520
68dc0745 521int
c5be433b 522do_aspawn(void *vreally, void **vmark, void **vsp)
0a753a76 523{
acfe0abc 524 dTHX;
2d7a9237
GS
525 SV *really = (SV*)vreally;
526 SV **mark = (SV**)vmark;
527 SV **sp = (SV**)vsp;
68dc0745 528 char **argv;
2d7a9237 529 char *str;
68dc0745 530 int status;
2d7a9237 531 int flag = P_WAIT;
68dc0745 532 int index = 0;
68dc0745 533
2d7a9237
GS
534 if (sp <= mark)
535 return -1;
68dc0745 536
ce1da67e
GS
537 get_shell();
538 New(1306, argv, (sp - mark) + w32_perlshell_items + 2, char*);
2d7a9237
GS
539
540 if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
541 ++mark;
542 flag = SvIVx(*mark);
68dc0745
PP
543 }
544
9404a519 545 while (++mark <= sp) {
bb897dfc 546 if (*mark && (str = SvPV_nolen(*mark)))
2d7a9237
GS
547 argv[index++] = str;
548 else
549 argv[index++] = "";
68dc0745
PP
550 }
551 argv[index++] = 0;
3fadfdf1 552
2d7a9237 553 status = win32_spawnvp(flag,
bb897dfc 554 (const char*)(really ? SvPV_nolen(really) : argv[0]),
2d7a9237
GS
555 (const char* const*)argv);
556
80252599 557 if (status < 0 && (errno == ENOEXEC || errno == ENOENT)) {
2d7a9237 558 /* possible shell-builtin, invoke with shell */
ce1da67e
GS
559 int sh_items;
560 sh_items = w32_perlshell_items;
2d7a9237
GS
561 while (--index >= 0)
562 argv[index+sh_items] = argv[index];
ce1da67e
GS
563 while (--sh_items >= 0)
564 argv[sh_items] = w32_perlshell_vec[sh_items];
3fadfdf1 565
2d7a9237 566 status = win32_spawnvp(flag,
bb897dfc 567 (const char*)(really ? SvPV_nolen(really) : argv[0]),
2d7a9237
GS
568 (const char* const*)argv);
569 }
68dc0745 570
922b1888
GS
571 if (flag == P_NOWAIT) {
572 if (IsWin95())
573 PL_statusvalue = -1; /* >16bits hint for pp_system() */
574 }
575 else {
50892819 576 if (status < 0) {
0453d815 577 if (ckWARN(WARN_EXEC))
f98bc0c6 578 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't spawn \"%s\": %s", argv[0], strerror(errno));
50892819
GS
579 status = 255 * 256;
580 }
581 else
582 status *= 256;
b28d0864 583 PL_statusvalue = status;
5aabfad6 584 }
ce1da67e 585 Safefree(argv);
50892819 586 return (status);
68dc0745
PP
587}
588
dd7038b3
JH
589/* returns pointer to the next unquoted space or the end of the string */
590static char*
591find_next_space(const char *s)
592{
593 bool in_quotes = FALSE;
594 while (*s) {
595 /* ignore doubled backslashes, or backslash+quote */
596 if (*s == '\\' && (s[1] == '\\' || s[1] == '"')) {
597 s += 2;
598 }
599 /* keep track of when we're within quotes */
600 else if (*s == '"') {
601 s++;
602 in_quotes = !in_quotes;
603 }
604 /* break it up only at spaces that aren't in quotes */
605 else if (!in_quotes && isSPACE(*s))
606 return (char*)s;
607 else
608 s++;
609 }
610 return (char*)s;
611}
612
c69f6586 613int
c5be433b 614do_spawn2(char *cmd, int exectype)
68dc0745 615{
acfe0abc 616 dTHX;
68dc0745
PP
617 char **a;
618 char *s;
619 char **argv;
620 int status = -1;
621 BOOL needToTry = TRUE;
2d7a9237 622 char *cmd2;
68dc0745 623
2d7a9237
GS
624 /* Save an extra exec if possible. See if there are shell
625 * metacharacters in it */
e200fe59 626 if (!has_shell_metachars(cmd)) {
fc36a67e
PP
627 New(1301,argv, strlen(cmd) / 2 + 2, char*);
628 New(1302,cmd2, strlen(cmd) + 1, char);
68dc0745
PP
629 strcpy(cmd2, cmd);
630 a = argv;
631 for (s = cmd2; *s;) {
de030af3 632 while (*s && isSPACE(*s))
68dc0745
PP
633 s++;
634 if (*s)
635 *(a++) = s;
dd7038b3 636 s = find_next_space(s);
9404a519 637 if (*s)
68dc0745 638 *s++ = '\0';
0a753a76 639 }
68dc0745 640 *a = Nullch;
ce1da67e 641 if (argv[0]) {
6890e559
GS
642 switch (exectype) {
643 case EXECF_SPAWN:
644 status = win32_spawnvp(P_WAIT, argv[0],
645 (const char* const*)argv);
646 break;
647 case EXECF_SPAWN_NOWAIT:
648 status = win32_spawnvp(P_NOWAIT, argv[0],
649 (const char* const*)argv);
650 break;
651 case EXECF_EXEC:
652 status = win32_execvp(argv[0], (const char* const*)argv);
653 break;
654 }
2d7a9237 655 if (status != -1 || errno == 0)
68dc0745 656 needToTry = FALSE;
0a753a76 657 }
0a753a76 658 Safefree(argv);
68dc0745
PP
659 Safefree(cmd2);
660 }
2d7a9237 661 if (needToTry) {
ce1da67e
GS
662 char **argv;
663 int i = -1;
664 get_shell();
665 New(1306, argv, w32_perlshell_items + 2, char*);
666 while (++i < w32_perlshell_items)
667 argv[i] = w32_perlshell_vec[i];
2d7a9237
GS
668 argv[i++] = cmd;
669 argv[i] = Nullch;
6890e559
GS
670 switch (exectype) {
671 case EXECF_SPAWN:
672 status = win32_spawnvp(P_WAIT, argv[0],
673 (const char* const*)argv);
674 break;
675 case EXECF_SPAWN_NOWAIT:
676 status = win32_spawnvp(P_NOWAIT, argv[0],
677 (const char* const*)argv);
678 break;
679 case EXECF_EXEC:
680 status = win32_execvp(argv[0], (const char* const*)argv);
681 break;
682 }
ce1da67e
GS
683 cmd = argv[0];
684 Safefree(argv);
68dc0745 685 }
922b1888
GS
686 if (exectype == EXECF_SPAWN_NOWAIT) {
687 if (IsWin95())
688 PL_statusvalue = -1; /* >16bits hint for pp_system() */
689 }
690 else {
50892819 691 if (status < 0) {
0453d815 692 if (ckWARN(WARN_EXEC))
f98bc0c6 693 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s",
50892819
GS
694 (exectype == EXECF_EXEC ? "exec" : "spawn"),
695 cmd, strerror(errno));
696 status = 255 * 256;
697 }
698 else
699 status *= 256;
b28d0864 700 PL_statusvalue = status;
5aabfad6 701 }
50892819 702 return (status);
0a753a76
PP
703}
704
6890e559 705int
c5be433b 706do_spawn(char *cmd)
6890e559 707{
c5be433b 708 return do_spawn2(cmd, EXECF_SPAWN);
6890e559
GS
709}
710
2d7a9237 711int
c5be433b 712do_spawn_nowait(char *cmd)
2d7a9237 713{
c5be433b 714 return do_spawn2(cmd, EXECF_SPAWN_NOWAIT);
2d7a9237
GS
715}
716
6890e559 717bool
4f63d024 718Perl_do_exec(pTHX_ char *cmd)
6890e559 719{
c5be433b 720 do_spawn2(cmd, EXECF_EXEC);
6890e559
GS
721 return FALSE;
722}
723
68dc0745
PP
724/* The idea here is to read all the directory names into a string table
725 * (separated by nulls) and when one of the other dir functions is called
726 * return the pointer to the current file name.
727 */
c5be433b 728DllExport DIR *
ce2e26e5 729win32_opendir(char *filename)
0a753a76 730{
acfe0abc 731 dTHX;
95136add 732 DIR *dirp;
9404a519
GS
733 long len;
734 long idx;
735 char scanname[MAX_PATH+3];
736 struct stat sbuf;
7fac1903
GS
737 WIN32_FIND_DATAA aFindData;
738 WIN32_FIND_DATAW wFindData;
9404a519 739 HANDLE fh;
7fac1903 740 char buffer[MAX_PATH*2];
82867ecf 741 WCHAR wbuffer[MAX_PATH+1];
95136add 742 char* ptr;
9404a519
GS
743
744 len = strlen(filename);
745 if (len > MAX_PATH)
746 return NULL;
68dc0745
PP
747
748 /* check to see if filename is a directory */
69d3ab13 749 if (win32_stat(filename, &sbuf) < 0 || !S_ISDIR(sbuf.st_mode))
24caa93f 750 return NULL;
68dc0745 751
68dc0745 752 /* Get us a DIR structure */
95136add 753 Newz(1303, dirp, 1, DIR);
68dc0745
PP
754
755 /* Create the search pattern */
756 strcpy(scanname, filename);
23db2e2d
GS
757
758 /* bare drive name means look in cwd for drive */
759 if (len == 2 && isALPHA(scanname[0]) && scanname[1] == ':') {
760 scanname[len++] = '.';
761 scanname[len++] = '/';
762 }
763 else if (scanname[len-1] != '/' && scanname[len-1] != '\\') {
9404a519 764 scanname[len++] = '/';
23db2e2d 765 }
9404a519
GS
766 scanname[len++] = '*';
767 scanname[len] = '\0';
68dc0745
PP
768
769 /* do the FindFirstFile call */
7fac1903 770 if (USING_WIDE()) {
0cb96387 771 A2WHELPER(scanname, wbuffer, sizeof(wbuffer));
7766f137 772 fh = FindFirstFileW(PerlDir_mapW(wbuffer), &wFindData);
7fac1903
GS
773 }
774 else {
7766f137 775 fh = FindFirstFileA(PerlDir_mapA(scanname), &aFindData);
7fac1903 776 }
95136add 777 dirp->handle = fh;
9404a519 778 if (fh == INVALID_HANDLE_VALUE) {
95136add 779 DWORD err = GetLastError();
21e72512 780 /* FindFirstFile() fails on empty drives! */
95136add
GS
781 switch (err) {
782 case ERROR_FILE_NOT_FOUND:
783 return dirp;
784 case ERROR_NO_MORE_FILES:
785 case ERROR_PATH_NOT_FOUND:
786 errno = ENOENT;
787 break;
788 case ERROR_NOT_ENOUGH_MEMORY:
789 errno = ENOMEM;
790 break;
791 default:
792 errno = EINVAL;
793 break;
794 }
795 Safefree(dirp);
68dc0745
PP
796 return NULL;
797 }
798
799 /* now allocate the first part of the string table for
800 * the filenames that we find.
801 */
7fac1903 802 if (USING_WIDE()) {
0cb96387 803 W2AHELPER(wFindData.cFileName, buffer, sizeof(buffer));
7fac1903
GS
804 ptr = buffer;
805 }
806 else {
807 ptr = aFindData.cFileName;
808 }
809 idx = strlen(ptr)+1;
95136add
GS
810 if (idx < 256)
811 dirp->size = 128;
812 else
813 dirp->size = idx;
814 New(1304, dirp->start, dirp->size, char);
815 strcpy(dirp->start, ptr);
816 dirp->nfiles++;
817 dirp->end = dirp->curr = dirp->start;
818 dirp->end += idx;
819 return dirp;
0a753a76
PP
820}
821
822
68dc0745
PP
823/* Readdir just returns the current string pointer and bumps the
824 * string pointer to the nDllExport entry.
825 */
c5be433b 826DllExport struct direct *
ce2e26e5 827win32_readdir(DIR *dirp)
0a753a76 828{
95136add 829 long len;
0a753a76 830
68dc0745
PP
831 if (dirp->curr) {
832 /* first set up the structure to return */
833 len = strlen(dirp->curr);
0f38926b 834 strcpy(dirp->dirstr.d_name, dirp->curr);
68dc0745 835 dirp->dirstr.d_namlen = len;
0a753a76 836
68dc0745 837 /* Fake an inode */
0f38926b 838 dirp->dirstr.d_ino = dirp->curr - dirp->start;
0a753a76 839
95136add 840 /* Now set up for the next call to readdir */
68dc0745 841 dirp->curr += len + 1;
95136add 842 if (dirp->curr >= dirp->end) {
acfe0abc 843 dTHX;
95136add
GS
844 char* ptr;
845 BOOL res;
846 WIN32_FIND_DATAW wFindData;
847 WIN32_FIND_DATAA aFindData;
848 char buffer[MAX_PATH*2];
849
850 /* finding the next file that matches the wildcard
851 * (which should be all of them in this directory!).
95136add
GS
852 */
853 if (USING_WIDE()) {
854 res = FindNextFileW(dirp->handle, &wFindData);
855 if (res) {
856 W2AHELPER(wFindData.cFileName, buffer, sizeof(buffer));
857 ptr = buffer;
858 }
859 }
860 else {
861 res = FindNextFileA(dirp->handle, &aFindData);
862 if (res)
863 ptr = aFindData.cFileName;
864 }
865 if (res) {
0f38926b
GS
866 long endpos = dirp->end - dirp->start;
867 long newsize = endpos + strlen(ptr) + 1;
95136add 868 /* bump the string table size by enough for the
022735b4 869 * new name and its null terminator */
0f38926b
GS
870 while (newsize > dirp->size) {
871 long curpos = dirp->curr - dirp->start;
95136add
GS
872 dirp->size *= 2;
873 Renew(dirp->start, dirp->size, char);
0f38926b 874 dirp->curr = dirp->start + curpos;
95136add 875 }
0f38926b
GS
876 strcpy(dirp->start + endpos, ptr);
877 dirp->end = dirp->start + newsize;
95136add
GS
878 dirp->nfiles++;
879 }
880 else
881 dirp->curr = NULL;
68dc0745 882 }
68dc0745 883 return &(dirp->dirstr);
3fadfdf1 884 }
68dc0745
PP
885 else
886 return NULL;
0a753a76
PP
887}
888
68dc0745 889/* Telldir returns the current string pointer position */
c5be433b 890DllExport long
ce2e26e5 891win32_telldir(DIR *dirp)
0a753a76 892{
95136add 893 return (dirp->curr - dirp->start);
0a753a76
PP
894}
895
896
68dc0745 897/* Seekdir moves the string pointer to a previously saved position
95136add 898 * (returned by telldir).
68dc0745 899 */
c5be433b 900DllExport void
ce2e26e5 901win32_seekdir(DIR *dirp, long loc)
0a753a76 902{
95136add 903 dirp->curr = dirp->start + loc;
0a753a76
PP
904}
905
68dc0745 906/* Rewinddir resets the string pointer to the start */
c5be433b 907DllExport void
ce2e26e5 908win32_rewinddir(DIR *dirp)
0a753a76
PP
909{
910 dirp->curr = dirp->start;
911}
912
68dc0745 913/* free the memory allocated by opendir */
c5be433b 914DllExport int
ce2e26e5 915win32_closedir(DIR *dirp)
0a753a76 916{
acfe0abc 917 dTHX;
95136add 918 if (dirp->handle != INVALID_HANDLE_VALUE)
0f38926b 919 FindClose(dirp->handle);
0a753a76
PP
920 Safefree(dirp->start);
921 Safefree(dirp);
68dc0745 922 return 1;
0a753a76
PP
923}
924
925
68dc0745
PP
926/*
927 * various stubs
928 */
0a753a76
PP
929
930
68dc0745
PP
931/* Ownership
932 *
933 * Just pretend that everyone is a superuser. NT will let us know if
934 * we don\'t really have permission to do something.
935 */
0a753a76
PP
936
937#define ROOT_UID ((uid_t)0)
938#define ROOT_GID ((gid_t)0)
939
68dc0745
PP
940uid_t
941getuid(void)
0a753a76 942{
68dc0745 943 return ROOT_UID;
0a753a76
PP
944}
945
68dc0745
PP
946uid_t
947geteuid(void)
0a753a76 948{
68dc0745 949 return ROOT_UID;
0a753a76
PP
950}
951
68dc0745
PP
952gid_t
953getgid(void)
0a753a76 954{
68dc0745 955 return ROOT_GID;
0a753a76
PP
956}
957
68dc0745
PP
958gid_t
959getegid(void)
0a753a76 960{
68dc0745 961 return ROOT_GID;
0a753a76
PP
962}
963
68dc0745 964int
22239a37 965setuid(uid_t auid)
3fadfdf1 966{
22239a37 967 return (auid == ROOT_UID ? 0 : -1);
0a753a76
PP
968}
969
68dc0745 970int
22239a37 971setgid(gid_t agid)
0a753a76 972{
22239a37 973 return (agid == ROOT_GID ? 0 : -1);
0a753a76
PP
974}
975
e34ffe5a
GS
976char *
977getlogin(void)
978{
acfe0abc 979 dTHX;
3352bfcb
GS
980 char *buf = w32_getlogin_buffer;
981 DWORD size = sizeof(w32_getlogin_buffer);
e34ffe5a
GS
982 if (GetUserName(buf,&size))
983 return buf;
984 return (char*)NULL;
985}
986
b990f8c8
GS
987int
988chown(const char *path, uid_t owner, gid_t group)
989{
990 /* XXX noop */
1c1c7f20 991 return 0;
b990f8c8
GS
992}
993
00b02797
JH
994/*
995 * XXX this needs strengthening (for PerlIO)
996 * -- BKS, 11-11-200
997*/
998int mkstemp(const char *path)
999{
1000 dTHX;
1001 char buf[MAX_PATH+1];
1002 int i = 0, fd = -1;
1003
1004retry:
1005 if (i++ > 10) { /* give up */
1006 errno = ENOENT;
1007 return -1;
1008 }
1009 if (!GetTempFileNameA((LPCSTR)path, "plr", 1, buf)) {
1010 errno = ENOENT;
1011 return -1;
1012 }
1013 fd = PerlLIO_open3(buf, O_CREAT|O_RDWR|O_EXCL, 0600);
1014 if (fd == -1)
1015 goto retry;
1016 return fd;
1017}
1018
0aaad0ff
GS
1019static long
1020find_pid(int pid)
0a753a76 1021{
acfe0abc 1022 dTHX;
7766f137
GS
1023 long child = w32_num_children;
1024 while (--child >= 0) {
0aaad0ff
GS
1025 if (w32_child_pids[child] == pid)
1026 return child;
1027 }
1028 return -1;
1029}
1030
1031static void
1032remove_dead_process(long child)
1033{
1034 if (child >= 0) {
acfe0abc 1035 dTHX;
0aaad0ff 1036 CloseHandle(w32_child_handles[child]);
c00206c8 1037 Move(&w32_child_handles[child+1], &w32_child_handles[child],
0aaad0ff 1038 (w32_num_children-child-1), HANDLE);
c00206c8 1039 Move(&w32_child_pids[child+1], &w32_child_pids[child],
0aaad0ff
GS
1040 (w32_num_children-child-1), DWORD);
1041 w32_num_children--;
f55ee38a 1042 }
f55ee38a
GS
1043}
1044
7766f137
GS
1045#ifdef USE_ITHREADS
1046static long
1047find_pseudo_pid(int pid)
1048{
acfe0abc 1049 dTHX;
7766f137
GS
1050 long child = w32_num_pseudo_children;
1051 while (--child >= 0) {
1052 if (w32_pseudo_child_pids[child] == pid)
1053 return child;
1054 }
1055 return -1;
1056}
1057
1058static void
1059remove_dead_pseudo_process(long child)
1060{
1061 if (child >= 0) {
acfe0abc 1062 dTHX;
7766f137 1063 CloseHandle(w32_pseudo_child_handles[child]);
c00206c8 1064 Move(&w32_pseudo_child_handles[child+1], &w32_pseudo_child_handles[child],
7766f137 1065 (w32_num_pseudo_children-child-1), HANDLE);
c00206c8 1066 Move(&w32_pseudo_child_pids[child+1], &w32_pseudo_child_pids[child],
7766f137
GS
1067 (w32_num_pseudo_children-child-1), DWORD);
1068 w32_num_pseudo_children--;
1069 }
1070}
1071#endif
1072
f55ee38a
GS
1073DllExport int
1074win32_kill(int pid, int sig)
1075{
acfe0abc 1076 dTHX;
0aaad0ff 1077 HANDLE hProcess;
c66b022d 1078 long child;
7766f137
GS
1079#ifdef USE_ITHREADS
1080 if (pid < 0) {
1081 /* it is a pseudo-forked child */
c66b022d 1082 child = find_pseudo_pid(-pid);
7766f137
GS
1083 if (child >= 0) {
1084 hProcess = w32_pseudo_child_handles[child];
7e5f34c0
NIS
1085 switch (sig) {
1086 case 0:
c843839f 1087 /* "Does process exist?" use of kill */
7766f137 1088 return 0;
7e5f34c0
NIS
1089 case 9:
1090 /* kill -9 style un-graceful exit */
1091 if (TerminateThread(hProcess, sig)) {
1092 remove_dead_pseudo_process(child);
1093 return 0;
1094 }
1095 break;
1096 default:
fb6be350
NK
1097 /* We fake signals to pseudo-processes using Win32
1098 * message queue. In Win9X the pids are negative already. */
1099 if (PostThreadMessage(IsWin95() ? pid : -pid,WM_USER,sig,0)) {
3fadfdf1 1100 /* It might be us ... */
7e5f34c0
NIS
1101 PERL_ASYNC_CHECK();
1102 return 0;
1103 }
1104 break;
1105 }
7766f137 1106 }
922b1888
GS
1107 else if (IsWin95()) {
1108 pid = -pid;
1109 goto alien_process;
1110 }
68dc0745 1111 }
7766f137
GS
1112 else
1113#endif
1114 {
c66b022d 1115 child = find_pid(pid);
7766f137 1116 if (child >= 0) {
7e5f34c0
NIS
1117 hProcess = w32_child_handles[child];
1118 switch(sig) {
1119 case 0:
c843839f 1120 /* "Does process exist?" use of kill */
7766f137 1121 return 0;
7e5f34c0
NIS
1122 case 2:
1123 if (GenerateConsoleCtrlEvent(CTRL_C_EVENT,pid))
1124 return 0;
1125 break;
c843839f 1126 default: /* For now be backwards compatible with perl5.6 */
7e5f34c0
NIS
1127 case 9:
1128 if (TerminateProcess(hProcess, sig)) {
1129 remove_dead_process(child);
1130 return 0;
1131 }
1132 break;
1133 }
7766f137
GS
1134 }
1135 else {
922b1888
GS
1136alien_process:
1137 hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE,
1138 (IsWin95() ? -pid : pid));
42b8b86c 1139 if (hProcess) {
7e5f34c0
NIS
1140 switch(sig) {
1141 case 0:
c843839f 1142 /* "Does process exist?" use of kill */
42b8b86c 1143 return 0;
7e5f34c0
NIS
1144 case 2:
1145 if (GenerateConsoleCtrlEvent(CTRL_C_EVENT,pid))
1146 return 0;
1147 break;
c843839f 1148 default: /* For now be backwards compatible with perl5.6 */
7e5f34c0
NIS
1149 case 9:
1150 if (TerminateProcess(hProcess, sig)) {
1151 CloseHandle(hProcess);
1152 return 0;
1153 }
42b8b86c 1154 }
7766f137
GS
1155 }
1156 }
1157 }
1158 errno = EINVAL;
1159 return -1;
0a753a76 1160}
fbbbcc48 1161
68dc0745 1162DllExport int
426c1a18 1163win32_stat(const char *path, struct stat *sbuf)
0a753a76 1164{
acfe0abc 1165 dTHX;
3fadfdf1 1166 char buffer[MAX_PATH+1];
68dc0745 1167 int l = strlen(path);
67fbe06e 1168 int res;
82867ecf 1169 WCHAR wbuffer[MAX_PATH+1];
e9ff6d27 1170 WCHAR* pwbuffer;
6b980173
JD
1171 HANDLE handle;
1172 int nlink = 1;
0a753a76 1173
68dc0745
PP
1174 if (l > 1) {
1175 switch(path[l - 1]) {
e1dbac94
GS
1176 /* FindFirstFile() and stat() are buggy with a trailing
1177 * backslash, so change it to a forward slash :-( */
68dc0745 1178 case '\\':
426c1a18
GS
1179 strncpy(buffer, path, l-1);
1180 buffer[l - 1] = '/';
1181 buffer[l] = '\0';
1182 path = buffer;
e1dbac94 1183 break;
23db2e2d 1184 /* FindFirstFile() is buggy with "x:", so add a dot :-( */
e1dbac94
GS
1185 case ':':
1186 if (l == 2 && isALPHA(path[0])) {
426c1a18
GS
1187 buffer[0] = path[0];
1188 buffer[1] = ':';
1189 buffer[2] = '.';
1190 buffer[3] = '\0';
e1dbac94 1191 l = 3;
426c1a18 1192 path = buffer;
e1dbac94
GS
1193 }
1194 break;
68dc0745
PP
1195 }
1196 }
6b980173
JD
1197
1198 /* We *must* open & close the file once; otherwise file attribute changes */
1199 /* might not yet have propagated to "other" hard links of the same file. */
1200 /* This also gives us an opportunity to determine the number of links. */
7fac1903 1201 if (USING_WIDE()) {
0cb96387 1202 A2WHELPER(path, wbuffer, sizeof(wbuffer));
e9ff6d27
GS
1203 pwbuffer = PerlDir_mapW(wbuffer);
1204 handle = CreateFileW(pwbuffer, 0, 0, NULL, OPEN_EXISTING, 0, NULL);
7fac1903
GS
1205 }
1206 else {
e9ff6d27
GS
1207 path = PerlDir_mapA(path);
1208 l = strlen(path);
1209 handle = CreateFileA(path, 0, 0, NULL, OPEN_EXISTING, 0, NULL);
6b980173
JD
1210 }
1211 if (handle != INVALID_HANDLE_VALUE) {
1212 BY_HANDLE_FILE_INFORMATION bhi;
1213 if (GetFileInformationByHandle(handle, &bhi))
1214 nlink = bhi.nNumberOfLinks;
1215 CloseHandle(handle);
7fac1903 1216 }
6b980173 1217
e9ff6d27 1218 /* pwbuffer or path will be mapped correctly above */
7766f137 1219 if (USING_WIDE()) {
e9ff6d27 1220 res = _wstat(pwbuffer, (struct _stat *)sbuf);
7766f137
GS
1221 }
1222 else {
e9ff6d27 1223 res = stat(path, sbuf);
7766f137 1224 }
426c1a18 1225 sbuf->st_nlink = nlink;
6b980173 1226
24caa93f
GS
1227 if (res < 0) {
1228 /* CRT is buggy on sharenames, so make sure it really isn't.
1229 * XXX using GetFileAttributesEx() will enable us to set
426c1a18 1230 * sbuf->st_*time (but note that's not available on the
24caa93f 1231 * Windows of 1995) */
7fac1903
GS
1232 DWORD r;
1233 if (USING_WIDE()) {
e9ff6d27 1234 r = GetFileAttributesW(pwbuffer);
7fac1903
GS
1235 }
1236 else {
e9ff6d27 1237 r = GetFileAttributesA(path);
7fac1903 1238 }
24caa93f 1239 if (r != 0xffffffff && (r & FILE_ATTRIBUTE_DIRECTORY)) {
426c1a18
GS
1240 /* sbuf may still contain old garbage since stat() failed */
1241 Zero(sbuf, 1, struct stat);
1242 sbuf->st_mode = S_IFDIR | S_IREAD;
24caa93f
GS
1243 errno = 0;
1244 if (!(r & FILE_ATTRIBUTE_READONLY))
426c1a18 1245 sbuf->st_mode |= S_IWRITE | S_IEXEC;
24caa93f
GS
1246 return 0;
1247 }
1248 }
24caa93f 1249 else {
e1dbac94
GS
1250 if (l == 3 && isALPHA(path[0]) && path[1] == ':'
1251 && (path[2] == '\\' || path[2] == '/'))
2293b0e9
AB
1252 {
1253 /* The drive can be inaccessible, some _stat()s are buggy */
7fac1903 1254 if (USING_WIDE()
e9ff6d27
GS
1255 ? !GetVolumeInformationW(pwbuffer,NULL,0,NULL,NULL,NULL,NULL,0)
1256 : !GetVolumeInformationA(path,NULL,0,NULL,NULL,NULL,NULL,0)) {
2293b0e9
AB
1257 errno = ENOENT;
1258 return -1;
1259 }
1260 }
1261#ifdef __BORLANDC__
426c1a18
GS
1262 if (S_ISDIR(sbuf->st_mode))
1263 sbuf->st_mode |= S_IWRITE | S_IEXEC;
1264 else if (S_ISREG(sbuf->st_mode)) {
d0650a05 1265 int perms;
67fbe06e
GS
1266 if (l >= 4 && path[l-4] == '.') {
1267 const char *e = path + l - 3;
1268 if (strnicmp(e,"exe",3)
1269 && strnicmp(e,"bat",3)
1270 && strnicmp(e,"com",3)
1271 && (IsWin95() || strnicmp(e,"cmd",3)))
426c1a18 1272 sbuf->st_mode &= ~S_IEXEC;
67fbe06e 1273 else
426c1a18 1274 sbuf->st_mode |= S_IEXEC;
67fbe06e
GS
1275 }
1276 else
426c1a18 1277 sbuf->st_mode &= ~S_IEXEC;
d0650a05
GS
1278 /* Propagate permissions to _group_ and _others_ */
1279 perms = sbuf->st_mode & (S_IREAD|S_IWRITE|S_IEXEC);
1280 sbuf->st_mode |= (perms>>3) | (perms>>6);
67fbe06e 1281 }
67fbe06e 1282#endif
2293b0e9 1283 }
67fbe06e 1284 return res;
0a753a76
PP
1285}
1286
bb27e7b6
JH
1287#define isSLASH(c) ((c) == '/' || (c) == '\\')
1288#define SKIP_SLASHES(s) \
1289 STMT_START { \
1290 while (*(s) && isSLASH(*(s))) \
1291 ++(s); \
1292 } STMT_END
1293#define COPY_NONSLASHES(d,s) \
1294 STMT_START { \
1295 while (*(s) && !isSLASH(*(s))) \
1296 *(d)++ = *(s)++; \
1297 } STMT_END
1298
8ac9c18d
GS
1299/* Find the longname of a given path. path is destructively modified.
1300 * It should have space for at least MAX_PATH characters. */
1301DllExport char *
1302win32_longpath(char *path)
1303{
1304 WIN32_FIND_DATA fdata;
1305 HANDLE fhand;
1306 char tmpbuf[MAX_PATH+1];
1307 char *tmpstart = tmpbuf;
1308 char *start = path;
1309 char sep;
1310 if (!path)
1311 return Nullch;
1312
1313 /* drive prefix */
bb27e7b6 1314 if (isALPHA(path[0]) && path[1] == ':') {
8ac9c18d
GS
1315 start = path + 2;
1316 *tmpstart++ = path[0];
1317 *tmpstart++ = ':';
1318 }
1319 /* UNC prefix */
bb27e7b6 1320 else if (isSLASH(path[0]) && isSLASH(path[1])) {
8ac9c18d 1321 start = path + 2;
52fcf7ee
GS
1322 *tmpstart++ = path[0];
1323 *tmpstart++ = path[1];
bb27e7b6
JH
1324 SKIP_SLASHES(start);
1325 COPY_NONSLASHES(tmpstart,start); /* copy machine name */
8ac9c18d 1326 if (*start) {
bb27e7b6
JH
1327 *tmpstart++ = *start++;
1328 SKIP_SLASHES(start);
1329 COPY_NONSLASHES(tmpstart,start); /* copy share name */
8ac9c18d
GS
1330 }
1331 }
8ac9c18d 1332 *tmpstart = '\0';
bb27e7b6
JH
1333 while (*start) {
1334 /* copy initial slash, if any */
1335 if (isSLASH(*start)) {
1336 *tmpstart++ = *start++;
1337 *tmpstart = '\0';
1338 SKIP_SLASHES(start);
1339 }
1340
1341 /* FindFirstFile() expands "." and "..", so we need to pass
1342 * those through unmolested */
1343 if (*start == '.'
1344 && (!start[1] || isSLASH(start[1])
1345 || (start[1] == '.' && (!start[2] || isSLASH(start[2])))))
1346 {
1347 COPY_NONSLASHES(tmpstart,start); /* copy "." or ".." */
1348 *tmpstart = '\0';
1349 continue;
1350 }
1351
1352 /* if this is the end, bust outta here */
1353 if (!*start)
1354 break;
8ac9c18d 1355
bb27e7b6
JH
1356 /* now we're at a non-slash; walk up to next slash */
1357 while (*start && !isSLASH(*start))
8ac9c18d 1358 ++start;
8ac9c18d
GS
1359
1360 /* stop and find full name of component */
bb27e7b6 1361 sep = *start;
8ac9c18d
GS
1362 *start = '\0';
1363 fhand = FindFirstFile(path,&fdata);
bb27e7b6 1364 *start = sep;
8ac9c18d 1365 if (fhand != INVALID_HANDLE_VALUE) {
bb27e7b6
JH
1366 STRLEN len = strlen(fdata.cFileName);
1367 if ((STRLEN)(tmpbuf + sizeof(tmpbuf) - tmpstart) > len) {
1368 strcpy(tmpstart, fdata.cFileName);
1369 tmpstart += len;
1370 FindClose(fhand);
1371 }
1372 else {
1373 FindClose(fhand);
1374 errno = ERANGE;
1375 return Nullch;
1376 }
8ac9c18d
GS
1377 }
1378 else {
1379 /* failed a step, just return without side effects */
bf49b057 1380 /*PerlIO_printf(Perl_debug_log, "Failed to find %s\n", path);*/
bb27e7b6 1381 errno = EINVAL;
8ac9c18d
GS
1382 return Nullch;
1383 }
1384 }
1385 strcpy(path,tmpbuf);
1386 return path;
1387}
1388
0551aaa8
GS
1389DllExport char *
1390win32_getenv(const char *name)
1391{
acfe0abc 1392 dTHX;
82867ecf 1393 WCHAR wBuffer[MAX_PATH+1];
0551aaa8 1394 DWORD needlen;
51371543 1395 SV *curitem = Nullsv;
58a50f62 1396
7fac1903 1397 if (USING_WIDE()) {
0cb96387 1398 A2WHELPER(name, wBuffer, sizeof(wBuffer));
51371543 1399 needlen = GetEnvironmentVariableW(wBuffer, NULL, 0);
7fac1903
GS
1400 }
1401 else
51371543 1402 needlen = GetEnvironmentVariableA(name,NULL,0);
58a50f62 1403 if (needlen != 0) {
51371543 1404 curitem = sv_2mortal(newSVpvn("", 0));
7fac1903 1405 if (USING_WIDE()) {
51371543
GS
1406 SV *acuritem;
1407 do {
1408 SvGROW(curitem, (needlen+1)*sizeof(WCHAR));
1409 needlen = GetEnvironmentVariableW(wBuffer,
1410 (WCHAR*)SvPVX(curitem),
1411 needlen);
1412 } while (needlen >= SvLEN(curitem)/sizeof(WCHAR));
c5be433b 1413 SvCUR_set(curitem, (needlen*sizeof(WCHAR))+1);
51371543
GS
1414 acuritem = sv_2mortal(newSVsv(curitem));
1415 W2AHELPER((WCHAR*)SvPVX(acuritem), SvPVX(curitem), SvCUR(curitem));
7fac1903
GS
1416 }
1417 else {
51371543
GS
1418 do {
1419 SvGROW(curitem, needlen+1);
1420 needlen = GetEnvironmentVariableA(name,SvPVX(curitem),
1421 needlen);
1422 } while (needlen >= SvLEN(curitem));
1423 SvCUR_set(curitem, needlen);
58a50f62 1424 }
0551aaa8 1425 }
c934e9d4 1426 else {
7a5f8e82 1427 /* allow any environment variables that begin with 'PERL'
c934e9d4 1428 to be stored in the registry */
51371543 1429 if (strncmp(name, "PERL", 4) == 0)
c5be433b 1430 (void)get_regstr(name, &curitem);
c69f6586 1431 }
51371543
GS
1432 if (curitem && SvCUR(curitem))
1433 return SvPVX(curitem);
58a50f62 1434
51371543 1435 return Nullch;
0551aaa8
GS
1436}
1437
ac5c734f
GS
1438DllExport int
1439win32_putenv(const char *name)
1440{
acfe0abc 1441 dTHX;
ac5c734f
GS
1442 char* curitem;
1443 char* val;
7fac1903
GS
1444 WCHAR* wCuritem;
1445 WCHAR* wVal;
1446 int length, relval = -1;
51371543 1447
73c4f7a1 1448 if (name) {
7fac1903
GS
1449 if (USING_WIDE()) {
1450 length = strlen(name)+1;
1451 New(1309,wCuritem,length,WCHAR);
c5be433b 1452 A2WHELPER(name, wCuritem, length*sizeof(WCHAR));
7fac1903 1453 wVal = wcschr(wCuritem, '=');
7766f137 1454 if (wVal) {
7fac1903 1455 *wVal++ = '\0';
7766f137 1456 if (SetEnvironmentVariableW(wCuritem, *wVal ? wVal : NULL))
7fac1903
GS
1457 relval = 0;
1458 }
1459 Safefree(wCuritem);
1460 }
1461 else {
1462 New(1309,curitem,strlen(name)+1,char);
1463 strcpy(curitem, name);
1464 val = strchr(curitem, '=');
7766f137 1465 if (val) {
7fac1903
GS
1466 /* The sane way to deal with the environment.
1467 * Has these advantages over putenv() & co.:
1468 * * enables us to store a truly empty value in the
1469 * environment (like in UNIX).
1470 * * we don't have to deal with RTL globals, bugs and leaks.
1471 * * Much faster.
1472 * Why you may want to enable USE_WIN32_RTL_ENV:
1473 * * environ[] and RTL functions will not reflect changes,
1474 * which might be an issue if extensions want to access
1475 * the env. via RTL. This cuts both ways, since RTL will
1476 * not see changes made by extensions that call the Win32
1477 * functions directly, either.
1478 * GSAR 97-06-07
1479 */
1480 *val++ = '\0';
7766f137 1481 if (SetEnvironmentVariableA(curitem, *val ? val : NULL))
7fac1903
GS
1482 relval = 0;
1483 }
1484 Safefree(curitem);
ac5c734f 1485 }
ac5c734f
GS
1486 }
1487 return relval;
1488}
1489
d55594ae 1490static long
2d7a9237 1491filetime_to_clock(PFILETIME ft)
d55594ae 1492{
7766f137
GS
1493 __int64 qw = ft->dwHighDateTime;
1494 qw <<= 32;
1495 qw |= ft->dwLowDateTime;
1496 qw /= 10000; /* File time ticks at 0.1uS, clock at 1mS */
1497 return (long) qw;
d55594ae
GS
1498}
1499
f3986ebb
GS
1500DllExport int
1501win32_times(struct tms *timebuf)
0a753a76 1502{
d55594ae
GS
1503 FILETIME user;
1504 FILETIME kernel;
1505 FILETIME dummy;
50ee8e5e 1506 clock_t process_time_so_far = clock();
3fadfdf1 1507 if (GetProcessTimes(GetCurrentProcess(), &dummy, &dummy,
d55594ae 1508 &kernel,&user)) {
2d7a9237
GS
1509 timebuf->tms_utime = filetime_to_clock(&user);
1510 timebuf->tms_stime = filetime_to_clock(&kernel);
d55594ae
GS
1511 timebuf->tms_cutime = 0;
1512 timebuf->tms_cstime = 0;
3fadfdf1 1513 } else {
d55594ae 1514 /* That failed - e.g. Win95 fallback to clock() */
50ee8e5e 1515 timebuf->tms_utime = process_time_so_far;
d55594ae
GS
1516 timebuf->tms_stime = 0;
1517 timebuf->tms_cutime = 0;
1518 timebuf->tms_cstime = 0;
1519 }
50ee8e5e 1520 return process_time_so_far;
0a753a76
PP
1521}
1522
9c51cf4c 1523/* fix utime() so it works on directories in NT */
ad0751ec
GS
1524static BOOL
1525filetime_from_time(PFILETIME pFileTime, time_t Time)
1526{
9c51cf4c 1527 struct tm *pTM = localtime(&Time);
ad0751ec 1528 SYSTEMTIME SystemTime;
9c51cf4c 1529 FILETIME LocalTime;
ad0751ec
GS
1530
1531 if (pTM == NULL)
1532 return FALSE;
1533
1534 SystemTime.wYear = pTM->tm_year + 1900;
1535 SystemTime.wMonth = pTM->tm_mon + 1;
1536 SystemTime.wDay = pTM->tm_mday;
1537 SystemTime.wHour = pTM->tm_hour;
1538 SystemTime.wMinute = pTM->tm_min;
1539 SystemTime.wSecond = pTM->tm_sec;
1540 SystemTime.wMilliseconds = 0;
1541
9c51cf4c
GS
1542 return SystemTimeToFileTime(&SystemTime, &LocalTime) &&
1543 LocalFileTimeToFileTime(&LocalTime, pFileTime);
ad0751ec
GS
1544}
1545
1546DllExport int
7766f137
GS
1547win32_unlink(const char *filename)
1548{
acfe0abc 1549 dTHX;
7766f137
GS
1550 int ret;
1551 DWORD attrs;
1552
1553 if (USING_WIDE()) {
82867ecf 1554 WCHAR wBuffer[MAX_PATH+1];
e9ff6d27 1555 WCHAR* pwBuffer;
7766f137
GS
1556
1557 A2WHELPER(filename, wBuffer, sizeof(wBuffer));
e9ff6d27
GS
1558 pwBuffer = PerlDir_mapW(wBuffer);
1559 attrs = GetFileAttributesW(pwBuffer);
c00206c8
GS
1560 if (attrs == 0xFFFFFFFF)
1561 goto fail;
7766f137 1562 if (attrs & FILE_ATTRIBUTE_READONLY) {
e9ff6d27
GS
1563 (void)SetFileAttributesW(pwBuffer, attrs & ~FILE_ATTRIBUTE_READONLY);
1564 ret = _wunlink(pwBuffer);
7766f137 1565 if (ret == -1)
e9ff6d27 1566 (void)SetFileAttributesW(pwBuffer, attrs);
7766f137
GS
1567 }
1568 else
e9ff6d27 1569 ret = _wunlink(pwBuffer);
7766f137
GS
1570 }
1571 else {
e9ff6d27
GS
1572 filename = PerlDir_mapA(filename);
1573 attrs = GetFileAttributesA(filename);
c00206c8
GS
1574 if (attrs == 0xFFFFFFFF)
1575 goto fail;
7766f137 1576 if (attrs & FILE_ATTRIBUTE_READONLY) {
e9ff6d27
GS
1577 (void)SetFileAttributesA(filename, attrs & ~FILE_ATTRIBUTE_READONLY);
1578 ret = unlink(filename);
7766f137 1579 if (ret == -1)
e9ff6d27 1580 (void)SetFileAttributesA(filename, attrs);
7766f137
GS
1581 }
1582 else
e9ff6d27 1583 ret = unlink(filename);
7766f137
GS
1584 }
1585 return ret;
c00206c8
GS
1586fail:
1587 errno = ENOENT;
1588 return -1;
7766f137
GS
1589}
1590
1591DllExport int
3b405fc5 1592win32_utime(const char *filename, struct utimbuf *times)
ad0751ec 1593{
acfe0abc 1594 dTHX;
ad0751ec
GS
1595 HANDLE handle;
1596 FILETIME ftCreate;
1597 FILETIME ftAccess;
1598 FILETIME ftWrite;
1599 struct utimbuf TimeBuffer;
82867ecf 1600 WCHAR wbuffer[MAX_PATH+1];
e9ff6d27 1601 WCHAR* pwbuffer;
ad0751ec 1602
7fac1903
GS
1603 int rc;
1604 if (USING_WIDE()) {
0cb96387 1605 A2WHELPER(filename, wbuffer, sizeof(wbuffer));
e9ff6d27
GS
1606 pwbuffer = PerlDir_mapW(wbuffer);
1607 rc = _wutime(pwbuffer, (struct _utimbuf*)times);
7fac1903
GS
1608 }
1609 else {
e9ff6d27
GS
1610 filename = PerlDir_mapA(filename);
1611 rc = utime(filename, times);
7fac1903 1612 }
ad0751ec
GS
1613 /* EACCES: path specifies directory or readonly file */
1614 if (rc == 0 || errno != EACCES /* || !IsWinNT() */)
1615 return rc;
1616
1617 if (times == NULL) {
1618 times = &TimeBuffer;
1619 time(&times->actime);
1620 times->modtime = times->actime;
1621 }
1622
1623 /* This will (and should) still fail on readonly files */
7fac1903 1624 if (USING_WIDE()) {
e9ff6d27 1625 handle = CreateFileW(pwbuffer, GENERIC_READ | GENERIC_WRITE,
7fac1903
GS
1626 FILE_SHARE_READ | FILE_SHARE_DELETE, NULL,
1627 OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL);
1628 }
1629 else {
e9ff6d27 1630 handle = CreateFileA(filename, GENERIC_READ | GENERIC_WRITE,
7fac1903
GS
1631 FILE_SHARE_READ | FILE_SHARE_DELETE, NULL,
1632 OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL);
1633 }
ad0751ec
GS
1634 if (handle == INVALID_HANDLE_VALUE)
1635 return rc;
1636
1637 if (GetFileTime(handle, &ftCreate, &ftAccess, &ftWrite) &&
1638 filetime_from_time(&ftAccess, times->actime) &&
1639 filetime_from_time(&ftWrite, times->modtime) &&
1640 SetFileTime(handle, &ftCreate, &ftAccess, &ftWrite))
1641 {
1642 rc = 0;
1643 }
1644
1645 CloseHandle(handle);
1646 return rc;
1647}
1648
2d7a9237 1649DllExport int
b2af26b1
GS
1650win32_uname(struct utsname *name)
1651{
1652 struct hostent *hep;
1653 STRLEN nodemax = sizeof(name->nodename)-1;
1654 OSVERSIONINFO osver;
1655
1656 memset(&osver, 0, sizeof(OSVERSIONINFO));
1657 osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
1658 if (GetVersionEx(&osver)) {
1659 /* sysname */
1660 switch (osver.dwPlatformId) {
1661 case VER_PLATFORM_WIN32_WINDOWS:
1662 strcpy(name->sysname, "Windows");
1663 break;
1664 case VER_PLATFORM_WIN32_NT:
1665 strcpy(name->sysname, "Windows NT");
1666 break;
1667 case VER_PLATFORM_WIN32s:
1668 strcpy(name->sysname, "Win32s");
1669 break;
1670 default:
1671 strcpy(name->sysname, "Win32 Unknown");
1672 break;
1673 }
1674
cf6cacac
GS
1675 /* release */
1676 sprintf(name->release, "%d.%d",
b2af26b1
GS
1677 osver.dwMajorVersion, osver.dwMinorVersion);
1678
cf6cacac
GS
1679 /* version */
1680 sprintf(name->version, "Build %d",
b2af26b1
GS
1681 osver.dwPlatformId == VER_PLATFORM_WIN32_NT
1682 ? osver.dwBuildNumber : (osver.dwBuildNumber & 0xffff));
1683 if (osver.szCSDVersion[0]) {
cf6cacac 1684 char *buf = name->version + strlen(name->version);
b2af26b1
GS
1685 sprintf(buf, " (%s)", osver.szCSDVersion);
1686 }
1687 }
1688 else {
1689 *name->sysname = '\0';
1690 *name->version = '\0';
1691 *name->release = '\0';
1692 }
1693
1694 /* nodename */
1695 hep = win32_gethostbyname("localhost");
1696 if (hep) {
1697 STRLEN len = strlen(hep->h_name);
1698 if (len <= nodemax) {
1699 strcpy(name->nodename, hep->h_name);
1700 }
1701 else {
1702 strncpy(name->nodename, hep->h_name, nodemax);
1703 name->nodename[nodemax] = '\0';
1704 }
1705 }
1706 else {
1707 DWORD sz = nodemax;
1708 if (!GetComputerName(name->nodename, &sz))
1709 *name->nodename = '\0';
1710 }
1711
1712 /* machine (architecture) */
1713 {
1714 SYSTEM_INFO info;
1715 char *arch;
1716 GetSystemInfo(&info);
a6c40364 1717
6f24f39d
JK
1718#if (defined(__BORLANDC__)&&(__BORLANDC__<=0x520)) \
1719 || (defined(__MINGW32__) && !defined(_ANONYMOUS_UNION))
a6c40364
GS
1720 switch (info.u.s.wProcessorArchitecture) {
1721#else
b2af26b1 1722 switch (info.wProcessorArchitecture) {
a6c40364 1723#endif
b2af26b1
GS
1724 case PROCESSOR_ARCHITECTURE_INTEL:
1725 arch = "x86"; break;
1726 case PROCESSOR_ARCHITECTURE_MIPS:
1727 arch = "mips"; break;
1728 case PROCESSOR_ARCHITECTURE_ALPHA:
1729 arch = "alpha"; break;
1730 case PROCESSOR_ARCHITECTURE_PPC:
1731 arch = "ppc"; break;
1732 default:
1733 arch = "unknown"; break;
1734 }
1735 strcpy(name->machine, arch);
1736 }
1737 return 0;
1738}
1739
8fb3fcfb
NIS
1740/* Timing related stuff */
1741
3fadfdf1
NIS
1742int
1743do_raise(pTHX_ int sig)
1744{
1745 if (sig < SIG_SIZE) {
1746 Sighandler_t handler = w32_sighandler[sig];
1747 if (handler == SIG_IGN) {
1748 return 0;
1749 }
1750 else if (handler != SIG_DFL) {
1751 (*handler)(sig);
1752 return 0;
1753 }
1754 else {
1755 /* Choose correct default behaviour */
1756 switch (sig) {
1757#ifdef SIGCLD
1758 case SIGCLD:
1759#endif
1760#ifdef SIGCHLD
1761 case SIGCHLD:
1762#endif
1763 case 0:
1764 return 0;
1765 case SIGTERM:
1766 default:
1767 break;
1768 }
1769 }
1770 }
1771 /* Tell caller to exit thread/process as approriate */
1772 return 1;
1773}
1774
1775void
1776sig_terminate(pTHX_ int sig)
1777{
1778 Perl_warn(aTHX_ "Terminating on signal SIG%s(%d)\n",PL_sig_name[sig], sig);
1779 /* exit() seems to be safe, my_exit() or die() is a problem in ^C
1780 thread
1781 */
1782 exit(sig);
1783}
1784
8fb3fcfb
NIS
1785DllExport int
1786win32_async_check(pTHX)
1787{
1788 MSG msg;
1789 int ours = 1;
7e5f34c0
NIS
1790 /* Passing PeekMessage -1 as HWND (2nd arg) only get PostThreadMessage() messages
1791 * and ignores window messages - should co-exist better with windows apps e.g. Tk
3fadfdf1 1792 */
222c300a 1793 while (PeekMessage(&msg, (HWND)-1, 0, 0, PM_REMOVE|PM_NOYIELD)) {
3fadfdf1 1794 int sig;
8fb3fcfb
NIS
1795 switch(msg.message) {
1796
7e5f34c0
NIS
1797#if 0
1798 /* Perhaps some other messages could map to signals ? ... */
1799 case WM_CLOSE:
3fadfdf1 1800 case WM_QUIT:
7e5f34c0 1801 /* Treat WM_QUIT like SIGHUP? */
3fadfdf1
NIS
1802 sig = SIGHUP;
1803 goto Raise;
7e5f34c0
NIS
1804 break;
1805#endif
1806
c843839f 1807 /* We use WM_USER to fake kill() with other signals */
8fb3fcfb 1808 case WM_USER: {
3fadfdf1
NIS
1809 sig = msg.wParam;
1810 Raise:
1811 if (do_raise(aTHX_ sig)) {
1812 sig_terminate(aTHX_ sig);
1813 }
8fb3fcfb
NIS
1814 break;
1815 }
3fadfdf1 1816
8fb3fcfb
NIS
1817 case WM_TIMER: {
1818 /* alarm() is a one-shot but SetTimer() repeats so kill it */
222c300a
NIS
1819 if (w32_timerid) {
1820 KillTimer(NULL,w32_timerid);
3fadfdf1
NIS
1821 w32_timerid=0;
1822 }
8fb3fcfb 1823 /* Now fake a call to signal handler */
3fadfdf1
NIS
1824 if (do_raise(aTHX_ 14)) {
1825 sig_terminate(aTHX_ 14);
1826 }
8fb3fcfb
NIS
1827 break;
1828 }
1829
1830 /* Otherwise do normal Win32 thing - in case it is useful */
1831 default:
1832 TranslateMessage(&msg);
1833 DispatchMessage(&msg);
1834 ours = 0;
1835 break;
1836 }
1837 }
05ec9bb3 1838 w32_poll_count = 0;
8fb3fcfb 1839
7e5f34c0 1840 /* Above or other stuff may have set a signal flag */
8fb3fcfb
NIS
1841 if (PL_sig_pending) {
1842 despatch_signals();
1843 }
3fadfdf1 1844 return ours;
8fb3fcfb
NIS
1845}
1846
1847DllExport DWORD
1848win32_msgwait(pTHX_ DWORD count, LPHANDLE handles, DWORD timeout, LPDWORD resultp)
1849{
1850 /* We may need several goes at this - so compute when we stop */
1851 DWORD ticks = 0;
1852 if (timeout != INFINITE) {
1853 ticks = GetTickCount();
1854 timeout += ticks;
1855 }
1856 while (1) {
1857 DWORD result = MsgWaitForMultipleObjects(count,handles,FALSE,timeout-ticks, QS_ALLEVENTS);
1858 if (resultp)
1859 *resultp = result;
1860 if (result == WAIT_TIMEOUT) {
3fadfdf1
NIS
1861 /* Ran out of time - explicit return of zero to avoid -ve if we
1862 have scheduling issues
1863 */
8fb3fcfb
NIS
1864 return 0;
1865 }
1866 if (timeout != INFINITE) {
1867 ticks = GetTickCount();
1868 }
1869 if (result == WAIT_OBJECT_0 + count) {
1870 /* Message has arrived - check it */
1871 if (win32_async_check(aTHX)) {
1872 /* was one of ours */
1873 break;
1874 }
1875 }
1876 else {
1877 /* Not timeout or message - one of handles is ready */
1878 break;
1879 }
1880 }
1881 /* compute time left to wait */
1882 ticks = timeout - ticks;
1883 /* If we are past the end say zero */
1884 return (ticks > 0) ? ticks : 0;
1885}
1886
932b7487
RC
1887int
1888win32_internal_wait(int *status, DWORD timeout)
1889{
1890 /* XXX this wait emulation only knows about processes
1891 * spawned via win32_spawnvp(P_NOWAIT, ...).
1892 */
1893 dTHX;
1894 int i, retval;
1895 DWORD exitcode, waitcode;
1896
1897#ifdef USE_ITHREADS
1898 if (w32_num_pseudo_children) {
8fb3fcfb
NIS
1899 win32_msgwait(aTHX_ w32_num_pseudo_children, w32_pseudo_child_handles,
1900 timeout, &waitcode);
932b7487
RC
1901 /* Time out here if there are no other children to wait for. */
1902 if (waitcode == WAIT_TIMEOUT) {
1903 if (!w32_num_children) {
1904 return 0;
1905 }
1906 }
1907 else if (waitcode != WAIT_FAILED) {
1908 if (waitcode >= WAIT_ABANDONED_0
1909 && waitcode < WAIT_ABANDONED_0 + w32_num_pseudo_children)
1910 i = waitcode - WAIT_ABANDONED_0;
1911 else
1912 i = waitcode - WAIT_OBJECT_0;
1913 if (GetExitCodeThread(w32_pseudo_child_handles[i], &exitcode)) {
1914 *status = (int)((exitcode & 0xff) << 8);
1915 retval = (int)w32_pseudo_child_pids[i];
1916 remove_dead_pseudo_process(i);
1917 return -retval;
1918 }
1919 }
1920 }
1921#endif
1922
1923 if (!w32_num_children) {
1924 errno = ECHILD;
1925 return -1;
1926 }
1927
1928 /* if a child exists, wait for it to die */
8fb3fcfb 1929 win32_msgwait(aTHX_ w32_num_children, w32_child_handles, timeout, &waitcode);
932b7487
RC
1930 if (waitcode == WAIT_TIMEOUT) {
1931 return 0;
1932 }
1933 if (waitcode != WAIT_FAILED) {
1934 if (waitcode >= WAIT_ABANDONED_0
1935 && waitcode < WAIT_ABANDONED_0 + w32_num_children)
1936 i = waitcode - WAIT_ABANDONED_0;
1937 else
1938 i = waitcode - WAIT_OBJECT_0;
1939 if (GetExitCodeProcess(w32_child_handles[i], &exitcode) ) {
1940 *status = (int)((exitcode & 0xff) << 8);
1941 retval = (int)w32_child_pids[i];
1942 remove_dead_process(i);
1943 return retval;
1944 }
1945 }
1946
1947FAILED:
1948 errno = GetLastError();
1949 return -1;
1950}
1951
b2af26b1 1952DllExport int
f55ee38a
GS
1953win32_waitpid(int pid, int *status, int flags)
1954{
acfe0abc 1955 dTHX;
922b1888 1956 DWORD timeout = (flags & WNOHANG) ? 0 : INFINITE;
0aaad0ff 1957 int retval = -1;
c66b022d 1958 long child;
7766f137 1959 if (pid == -1) /* XXX threadid == 1 ? */
932b7487 1960 return win32_internal_wait(status, timeout);
7766f137
GS
1961#ifdef USE_ITHREADS
1962 else if (pid < 0) {
c66b022d 1963 child = find_pseudo_pid(-pid);
7766f137
GS
1964 if (child >= 0) {
1965 HANDLE hThread = w32_pseudo_child_handles[child];
8fb3fcfb
NIS
1966 DWORD waitcode;
1967 win32_msgwait(aTHX_ 1, &hThread, timeout, &waitcode);
2f67576d
BC
1968 if (waitcode == WAIT_TIMEOUT) {
1969 return 0;
1970 }
8fb3fcfb 1971 else if (waitcode == WAIT_OBJECT_0) {
7766f137
GS
1972 if (GetExitCodeThread(hThread, &waitcode)) {
1973 *status = (int)((waitcode & 0xff) << 8);
1974 retval = (int)w32_pseudo_child_pids[child];
1975 remove_dead_pseudo_process(child);
68a29c53 1976 return -retval;
7766f137
GS
1977 }
1978 }
1979 else
1980 errno = ECHILD;
1981 }
922b1888
GS
1982 else if (IsWin95()) {
1983 pid = -pid;
1984 goto alien_process;
1985 }
7766f137
GS
1986 }
1987#endif
f55ee38a 1988 else {
922b1888
GS
1989 HANDLE hProcess;
1990 DWORD waitcode;
c66b022d 1991 child = find_pid(pid);
0aaad0ff 1992 if (child >= 0) {
922b1888 1993 hProcess = w32_child_handles[child];
8fb3fcfb 1994 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
a7867d0a
GS
1995 if (waitcode == WAIT_TIMEOUT) {
1996 return 0;
1997 }
8fb3fcfb 1998 else if (waitcode == WAIT_OBJECT_0) {
922b1888
GS
1999 if (GetExitCodeProcess(hProcess, &waitcode)) {
2000 *status = (int)((waitcode & 0xff) << 8);
2001 retval = (int)w32_child_pids[child];
2002 remove_dead_process(child);
2003 return retval;
2004 }
a7867d0a 2005 }
0aaad0ff
GS
2006 else
2007 errno = ECHILD;
2008 }
2009 else {
922b1888
GS
2010alien_process:
2011 hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE,
2012 (IsWin95() ? -pid : pid));
2013 if (hProcess) {
8fb3fcfb 2014 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
922b1888
GS
2015 if (waitcode == WAIT_TIMEOUT) {
2016 return 0;
2017 }
8fb3fcfb 2018 else if (waitcode == WAIT_OBJECT_0) {
922b1888
GS
2019 if (GetExitCodeProcess(hProcess, &waitcode)) {
2020 *status = (int)((waitcode & 0xff) << 8);
2021 CloseHandle(hProcess);
2022 return pid;
2023 }
2024 }
2025 CloseHandle(hProcess);
2026 }
2027 else
2028 errno = ECHILD;
0aaad0ff 2029 }
f55ee38a 2030 }
3fadfdf1 2031 return retval >= 0 ? pid : retval;
f55ee38a
GS
2032}
2033
2034DllExport int
2d7a9237
GS
2035win32_wait(int *status)
2036{
932b7487 2037 return win32_internal_wait(status, INFINITE);
2d7a9237 2038}
d55594ae 2039
8fb3fcfb
NIS
2040DllExport unsigned int
2041win32_sleep(unsigned int t)
d55594ae 2042{
acfe0abc 2043 dTHX;
8fb3fcfb
NIS
2044 /* Win32 times are in ms so *1000 in and /1000 out */
2045 return win32_msgwait(aTHX_ 0, NULL, t*1000, NULL)/1000;
d55594ae
GS
2046}
2047
f3986ebb
GS
2048DllExport unsigned int
2049win32_alarm(unsigned int sec)
0a753a76 2050{
3fadfdf1 2051 /*
d55594ae 2052 * the 'obvious' implentation is SetTimer() with a callback
3fadfdf1
NIS
2053 * which does whatever receiving SIGALRM would do
2054 * we cannot use SIGALRM even via raise() as it is not
d55594ae 2055 * one of the supported codes in <signal.h>
3fadfdf1 2056 */
acfe0abc 2057 dTHX;
8fb3fcfb
NIS
2058 if (sec) {
2059 w32_timerid = SetTimer(NULL,w32_timerid,sec*1000,NULL);
2060 }
2061 else {
2062 if (w32_timerid) {
2063 KillTimer(NULL,w32_timerid);
3fadfdf1 2064 w32_timerid=0;
8fb3fcfb 2065 }
3fadfdf1 2066 }
afe91769 2067 return 0;
0a753a76
PP
2068}
2069
26618a56 2070#ifdef HAVE_DES_FCRYPT
2d77217b 2071extern char * des_fcrypt(const char *txt, const char *salt, char *cbuf);
ff95b63e 2072#endif
26618a56
GS
2073
2074DllExport char *
2075win32_crypt(const char *txt, const char *salt)
2076{
acfe0abc 2077 dTHX;
ff95b63e 2078#ifdef HAVE_DES_FCRYPT
3352bfcb 2079 return des_fcrypt(txt, salt, w32_crypt_buffer);
ff95b63e 2080#else
25dbdbbc 2081 Perl_croak(aTHX_ "The crypt() function is unimplemented due to excessive paranoia.");
b8957cf1 2082 return Nullch;
ff95b63e 2083#endif
26618a56 2084}
26618a56 2085
9e5f57de 2086#ifdef USE_FIXED_OSFHANDLE
390b85e7
GS
2087
2088#define FOPEN 0x01 /* file handle open */
b181b6fb 2089#define FNOINHERIT 0x10 /* file handle opened O_NOINHERIT */
390b85e7
GS
2090#define FAPPEND 0x20 /* file handle opened O_APPEND */
2091#define FDEV 0x40 /* file handle refers to device */
2092#define FTEXT 0x80 /* file handle is in text mode */
2093
390b85e7
GS
2094/***
2095*int my_open_osfhandle(long osfhandle, int flags) - open C Runtime file handle
2096*
2097*Purpose:
2098* This function allocates a free C Runtime file handle and associates
2099* it with the Win32 HANDLE specified by the first parameter. This is a
9e5f57de
GS
2100* temperary fix for WIN95's brain damage GetFileType() error on socket
2101* we just bypass that call for socket
2102*
2103* This works with MSVC++ 4.0+ or GCC/Mingw32
390b85e7
GS
2104*
2105*Entry:
2106* long osfhandle - Win32 HANDLE to associate with C Runtime file handle.
2107* int flags - flags to associate with C Runtime file handle.
2108*
2109*Exit:
2110* returns index of entry in fh, if successful
2111* return -1, if no free entry is found
2112*
2113*Exceptions:
2114*
2115*******************************************************************************/
2116
9e5f57de
GS
2117/*
2118 * we fake up some parts of the CRT that aren't exported by MSVCRT.dll
2119 * this lets sockets work on Win9X with GCC and should fix the problems
2120 * with perl95.exe
2121 * -- BKS, 1-23-2000
2122*/
2123
9e5f57de
GS
2124/* create an ioinfo entry, kill its handle, and steal the entry */
2125
b181b6fb
GS
2126static int
2127_alloc_osfhnd(void)
9e5f57de
GS
2128{
2129 HANDLE hF = CreateFile("NUL", 0, 0, NULL, OPEN_ALWAYS, 0, NULL);
dd8f4818 2130 int fh = _open_osfhandle((long)hF, 0);
9e5f57de
GS
2131 CloseHandle(hF);
2132 if (fh == -1)
2133 return fh;
2134 EnterCriticalSection(&(_pioinfo(fh)->lock));
2135 return fh;
2136}
2137
390b85e7
GS
2138static int
2139my_open_osfhandle(long osfhandle, int flags)
2140{
2141 int fh;
2142 char fileflags; /* _osfile flags */
2143
2144 /* copy relevant flags from second parameter */
2145 fileflags = FDEV;
2146
9404a519 2147 if (flags & O_APPEND)
390b85e7
GS
2148 fileflags |= FAPPEND;
2149
9404a519 2150 if (flags & O_TEXT)
390b85e7
GS
2151 fileflags |= FTEXT;
2152
b181b6fb
GS
2153 if (flags & O_NOINHERIT)
2154 fileflags |= FNOINHERIT;
2155
390b85e7 2156 /* attempt to allocate a C Runtime file handle */
9404a519 2157 if ((fh = _alloc_osfhnd()) == -1) {
390b85e7
GS
2158 errno = EMFILE; /* too many open files */
2159 _doserrno = 0L; /* not an OS error */
2160 return -1; /* return error to caller */
2161 }
2162
2163 /* the file is open. now, set the info in _osfhnd array */
2164 _set_osfhnd(fh, osfhandle);
2165
2166 fileflags |= FOPEN; /* mark as open */
2167
390b85e7 2168 _osfile(fh) = fileflags; /* set osfile entry */
dd8f4818 2169 LeaveCriticalSection(&_pioinfo(fh)->lock);
390b85e7
GS
2170
2171 return fh; /* return handle */
2172}
2173
f3986ebb 2174#endif /* USE_FIXED_OSFHANDLE */
390b85e7
GS
2175
2176/* simulate flock by locking a range on the file */
2177
2178#define LK_ERR(f,i) ((f) ? (i = 0) : (errno = GetLastError()))
2179#define LK_LEN 0xffff0000
2180
f3986ebb
GS
2181DllExport int
2182win32_flock(int fd, int oper)
390b85e7
GS
2183{
2184 OVERLAPPED o;
2185 int i = -1;
2186 HANDLE fh;
2187
f3986ebb 2188 if (!IsWinNT()) {
acfe0abc 2189 dTHX;
4f63d024 2190 Perl_croak_nocontext("flock() unimplemented on this platform");
f3986ebb
GS
2191 return -1;
2192 }
390b85e7
GS
2193 fh = (HANDLE)_get_osfhandle(fd);
2194 memset(&o, 0, sizeof(o));
2195
2196 switch(oper) {
2197 case LOCK_SH: /* shared lock */
2198 LK_ERR(LockFileEx(fh, 0, 0, LK_LEN, 0, &o),i);
2199 break;
2200 case LOCK_EX: /* exclusive lock */
2201 LK_ERR(LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK, 0, LK_LEN, 0, &o),i);
2202 break;
2203 case LOCK_SH|LOCK_NB: /* non-blocking shared lock */
2204 LK_ERR(LockFileEx(fh, LOCKFILE_FAIL_IMMEDIATELY, 0, LK_LEN, 0, &o),i);
2205 break;
2206 case LOCK_EX|LOCK_NB: /* non-blocking exclusive lock */
2207 LK_ERR(LockFileEx(fh,
2208 LOCKFILE_EXCLUSIVE_LOCK|LOCKFILE_FAIL_IMMEDIATELY,
2209 0, LK_LEN, 0, &o),i);
2210 break;
2211 case LOCK_UN: /* unlock lock */
2212 LK_ERR(UnlockFileEx(fh, 0, LK_LEN, 0, &o),i);
2213 break;
2214 default: /* unknown */
2215 errno = EINVAL;
2216 break;
2217 }
2218 return i;
2219}
2220
2221#undef LK_ERR
2222#undef LK_LEN
2223
68dc0745
PP
2224/*
2225 * redirected io subsystem for all XS modules
2226 *
2227 */
0a753a76 2228
68dc0745
PP
2229DllExport int *
2230win32_errno(void)
0a753a76 2231{
390b85e7 2232 return (&errno);
0a753a76
PP
2233}
2234
dcb2879a
GS
2235DllExport char ***
2236win32_environ(void)
2237{
390b85e7 2238 return (&(_environ));
dcb2879a
GS
2239}
2240
68dc0745
PP
2241/* the rest are the remapped stdio routines */
2242DllExport FILE *
2243win32_stderr(void)
0a753a76 2244{
390b85e7 2245 return (stderr);
0a753a76
PP
2246}
2247
68dc0745
PP
2248DllExport FILE *
2249win32_stdin(void)
0a753a76 2250{
390b85e7 2251 return (stdin);
0a753a76
PP
2252}
2253
68dc0745
PP
2254DllExport FILE *
2255win32_stdout()
0a753a76 2256{
390b85e7 2257 return (stdout);
0a753a76
PP
2258}
2259
68dc0745
PP
2260DllExport int
2261win32_ferror(FILE *fp)
0a753a76 2262{
390b85e7 2263 return (ferror(fp));
0a753a76
PP
2264}
2265
2266
68dc0745
PP
2267DllExport int
2268win32_feof(FILE *fp)
0a753a76 2269{
390b85e7 2270 return (feof(fp));
0a753a76
PP
2271}
2272
68dc0745 2273/*
3fadfdf1 2274 * Since the errors returned by the socket error function
68dc0745
PP
2275 * WSAGetLastError() are not known by the library routine strerror
2276 * we have to roll our own.
2277 */
0a753a76 2278
68dc0745 2279DllExport char *
3fadfdf1 2280win32_strerror(int e)
0a753a76 2281{
6f24f39d 2282#if !defined __BORLANDC__ && !defined __MINGW32__ /* compiler intolerance */
68dc0745 2283 extern int sys_nerr;
3e3baf6d 2284#endif
68dc0745 2285 DWORD source = 0;
0a753a76 2286
9404a519 2287 if (e < 0 || e > sys_nerr) {
acfe0abc 2288 dTHX;
9404a519 2289 if (e < 0)
68dc0745 2290 e = GetLastError();
0a753a76 2291
9404a519 2292 if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, &source, e, 0,
3352bfcb 2293 w32_strerror_buffer,
3fadfdf1 2294 sizeof(w32_strerror_buffer), NULL) == 0)
3352bfcb 2295 strcpy(w32_strerror_buffer, "Unknown Error");
0a753a76 2296
3352bfcb 2297 return w32_strerror_buffer;
68dc0745 2298 }
390b85e7 2299 return strerror(e);
0a753a76
PP
2300}
2301
22fae026 2302DllExport void
c5be433b 2303win32_str_os_error(void *sv, DWORD dwErr)
22fae026
TM
2304{
2305 DWORD dwLen;
2306 char *sMsg;
2307 dwLen = FormatMessageA(FORMAT_MESSAGE_ALLOCATE_BUFFER
2308 |FORMAT_MESSAGE_IGNORE_INSERTS
2309 |FORMAT_MESSAGE_FROM_SYSTEM, NULL,
2310 dwErr, 0, (char *)&sMsg, 1, NULL);
2ce77adf 2311 /* strip trailing whitespace and period */
22fae026 2312 if (0 < dwLen) {
2ce77adf
GS
2313 do {
2314 --dwLen; /* dwLen doesn't include trailing null */
2315 } while (0 < dwLen && isSPACE(sMsg[dwLen]));
22fae026
TM
2316 if ('.' != sMsg[dwLen])
2317 dwLen++;
2ce77adf 2318 sMsg[dwLen] = '\0';
22fae026
TM
2319 }
2320 if (0 == dwLen) {
c69f6586 2321 sMsg = (char*)LocalAlloc(0, 64/**sizeof(TCHAR)*/);
db7c17d7
GS
2322 if (sMsg)
2323 dwLen = sprintf(sMsg,
2324 "Unknown error #0x%lX (lookup 0x%lX)",
2325 dwErr, GetLastError());
2326 }
2327 if (sMsg) {
acfe0abc 2328 dTHX;
db7c17d7
GS
2329 sv_setpvn((SV*)sv, sMsg, dwLen);
2330 LocalFree(sMsg);
22fae026 2331 }
22fae026
TM
2332}
2333
68dc0745
PP
2334DllExport int
2335win32_fprintf(FILE *fp, const char *format, ...)
0a753a76 2336{
68dc0745
PP
2337 va_list marker;
2338 va_start(marker, format); /* Initialize variable arguments. */
0a753a76 2339
390b85e7 2340 return (vfprintf(fp, format, marker));
0a753a76
PP
2341}
2342
68dc0745
PP
2343DllExport int
2344win32_printf(const char *format, ...)
0a753a76 2345{
68dc0745
PP
2346 va_list marker;
2347 va_start(marker, format); /* Initialize variable arguments. */
0a753a76 2348
390b85e7 2349 return (vprintf(format, marker));
0a753a76
PP
2350}
2351
68dc0745
PP
2352DllExport int
2353win32_vfprintf(FILE *fp, const char *format, va_list args)
0a753a76 2354{
390b85e7 2355 return (vfprintf(fp, format, args));
0a753a76
PP
2356}
2357
96e4d5b1
PP
2358DllExport int
2359win32_vprintf(const char *format, va_list args)
2360{
390b85e7 2361 return (vprintf(format, args));
96e4d5b1
PP
2362}
2363
68dc0745
PP
2364DllExport size_t
2365win32_fread(void *buf, size_t size, size_t count, FILE *fp)
0a753a76 2366{
390b85e7 2367 return fread(buf, size, count, fp);
0a753a76
PP
2368}
2369
68dc0745
PP
2370DllExport size_t
2371win32_fwrite(const void *buf, size_t size, size_t count, FILE *fp)
0a753a76 2372{
390b85e7 2373 return fwrite(buf, size, count, fp);
0a753a76
PP
2374}
2375
7fac1903
GS
2376#define MODE_SIZE 10
2377
68dc0745
PP
2378DllExport FILE *
2379win32_fopen(const char *filename, const char *mode)
0a753a76 2380{
acfe0abc 2381 dTHX;
82867ecf 2382 WCHAR wMode[MODE_SIZE], wBuffer[MAX_PATH+1];
1c5905c2 2383 FILE *f;
3fadfdf1 2384
c5be433b
GS
2385 if (!*filename)
2386 return NULL;
2387
68dc0745 2388 if (stricmp(filename, "/dev/null")==0)
7fac1903
GS
2389 filename = "NUL";
2390
2391 if (USING_WIDE()) {
0cb96387
GS
2392 A2WHELPER(mode, wMode, sizeof(wMode));
2393 A2WHELPER(filename, wBuffer, sizeof(wBuffer));
1c5905c2 2394 f = _wfopen(PerlDir_mapW(wBuffer), wMode);
7fac1903 2395 }
1c5905c2
GS
2396 else
2397 f = fopen(PerlDir_mapA(filename), mode);
2398 /* avoid buffering headaches for child processes */
2399 if (f && *mode == 'a')
2400 win32_fseek(f, 0, SEEK_END);
2401 return f;
0a753a76
PP
2402}
2403
f3986ebb
GS
2404#ifndef USE_SOCKETS_AS_HANDLES
2405#undef fdopen
2406#define fdopen my_fdopen
2407#endif
2408
68dc0745 2409DllExport FILE *
7fac1903 2410win32_fdopen(int handle, const char *mode)
0a753a76 2411{
acfe0abc 2412 dTHX;
51371543 2413 WCHAR wMode[MODE_SIZE];
1c5905c2 2414 FILE *f;
7fac1903 2415 if (USING_WIDE()) {
0cb96387 2416 A2WHELPER(mode, wMode, sizeof(wMode));
1c5905c2 2417 f = _wfdopen(handle, wMode);
7fac1903 2418 }
1c5905c2
GS
2419 else
2420 f = fdopen(handle, (char *) mode);
2421 /* avoid buffering headaches for child processes */
2422 if (f && *mode == 'a')
2423 win32_fseek(f, 0, SEEK_END);
2424 return f;
0a753a76
PP
2425}
2426
68dc0745 2427DllExport FILE *
7fac1903 2428win32_freopen(const char *path, const char *mode, FILE *stream)
0a753a76 2429{
acfe0abc 2430 dTHX;
82867ecf 2431 WCHAR wMode[MODE_SIZE], wBuffer[MAX_PATH+1];
68dc0745 2432 if (stricmp(path, "/dev/null")==0)
7fac1903
GS
2433 path = "NUL";
2434
2435 if (USING_WIDE()) {
0cb96387
GS
2436 A2WHELPER(mode, wMode, sizeof(wMode));
2437 A2WHELPER(path, wBuffer, sizeof(wBuffer));
7766f137 2438 return _wfreopen(PerlDir_mapW(wBuffer), wMode, stream);
7fac1903 2439 }
7766f137 2440 return freopen(PerlDir_mapA(path), mode, stream);
0a753a76
PP
2441}
2442
68dc0745
PP
2443DllExport int
2444win32_fclose(FILE *pf)
0a753a76 2445{
f3986ebb 2446 return my_fclose(pf); /* defined in win32sck.c */
0a753a76
PP
2447}
2448
68dc0745
PP
2449DllExport int
2450win32_fputs(const char *s,FILE *pf)
0a753a76 2451{
390b85e7 2452 return fputs(s, pf);
0a753a76
PP
2453}
2454
68dc0745
PP
2455DllExport int
2456win32_fputc(int c,FILE *pf)
0a753a76 2457{
390b85e7 2458 return fputc(c,pf);
0a753a76
PP
2459}
2460
68dc0745
PP
2461DllExport int
2462win32_ungetc(int c,FILE *pf)
0a753a76 2463{
390b85e7 2464 return ungetc(c,pf);
0a753a76
PP
2465}
2466
68dc0745
PP
2467DllExport int
2468win32_getc(FILE *pf)
0a753a76 2469{
390b85e7 2470 return getc(pf);
0a753a76
PP
2471}
2472
68dc0745
PP
2473DllExport int
2474win32_fileno(FILE *pf)
0a753a76 2475{
390b85e7 2476 return fileno(pf);
0a753a76
PP
2477}
2478
68dc0745
PP
2479DllExport void
2480win32_clearerr(FILE *pf)
0a753a76 2481{
390b85e7 2482 clearerr(pf);
68dc0745 2483 return;
0a753a76
PP
2484}
2485
68dc0745
PP
2486DllExport int
2487win32_fflush(FILE *pf)
0a753a76 2488{
390b85e7 2489 return fflush(pf);
0a753a76
PP
2490}
2491
68dc0745
PP
2492DllExport long
2493win32_ftell(FILE *pf)
0a753a76 2494{
390b85e7 2495 return ftell(pf);
0a753a76
PP
2496}
2497
68dc0745
PP
2498DllExport int
2499win32_fseek(FILE *pf,long offset,int origin)
0a753a76 2500{
390b85e7 2501 return fseek(pf, offset, origin);
0a753a76
PP
2502}
2503
68dc0745
PP
2504DllExport int
2505win32_fgetpos(FILE *pf,fpos_t *p)
0a753a76 2506{
390b85e7 2507 return fgetpos(pf, p);
0a753a76
PP
2508}
2509
68dc0745
PP
2510DllExport int
2511win32_fsetpos(FILE *pf,const fpos_t *p)
0a753a76 2512{
390b85e7 2513 return fsetpos(pf, p);
0a753a76
PP
2514}
2515
68dc0745
PP
2516DllExport void
2517win32_rewind(FILE *pf)
0a753a76 2518{
390b85e7 2519 rewind(pf);
68dc0745 2520 return;
0a753a76
PP
2521}
2522
68dc0745
PP
2523DllExport FILE*
2524win32_tmpfile(void)
0a753a76 2525{
b3122bc4
JH
2526 dTHX;
2527 char prefix[MAX_PATH+1];
2528 char filename[MAX_PATH+1];
2529 DWORD len = GetTempPath(MAX_PATH, prefix);
2530 if (len && len < MAX_PATH) {
2531 if (GetTempFileName(prefix, "plx", 0, filename)) {
2532 HANDLE fh = CreateFile(filename,
2533 DELETE | GENERIC_READ | GENERIC_WRITE,
2534 0,
2535 NULL,
2536 CREATE_ALWAYS,
2537 FILE_ATTRIBUTE_NORMAL
2538 | FILE_FLAG_DELETE_ON_CLOSE,
2539 NULL);
2540 if (fh != INVALID_HANDLE_VALUE) {
2541 int fd = win32_open_osfhandle((long)fh, 0);
2542 if (fd >= 0) {
a051bdb4
VK
2543#if defined(__BORLANDC__)
2544 setmode(fd,O_BINARY);
2545#endif
b3122bc4
JH
2546 DEBUG_p(PerlIO_printf(Perl_debug_log,
2547 "Created tmpfile=%s\n",filename));
2548 return fdopen(fd, "w+b");
2549 }
2550 }
2551 }
2552 }
2553 return NULL;
0a753a76
PP
2554}
2555
68dc0745
PP
2556DllExport void
2557win32_abort(void)
0a753a76 2558{
390b85e7 2559 abort();
68dc0745 2560 return;
0a753a76
PP
2561}
2562
68dc0745 2563DllExport int
22239a37 2564win32_fstat(int fd,struct stat *sbufptr)
0a753a76 2565{
2a07f407
VK
2566#ifdef __BORLANDC__
2567 /* A file designated by filehandle is not shown as accessible
2568 * for write operations, probably because it is opened for reading.
2569 * --Vadim Konovalov
3fadfdf1 2570 */
2a07f407
VK
2571 int rc = fstat(fd,sbufptr);
2572 BY_HANDLE_FILE_INFORMATION bhfi;
2573 if (GetFileInformationByHandle((HANDLE)_get_osfhandle(fd), &bhfi)) {
2574 sbufptr->st_mode &= 0xFE00;
2575 if (bhfi.dwFileAttributes & FILE_ATTRIBUTE_READONLY)
2576 sbufptr->st_mode |= (S_IREAD + (S_IREAD >> 3) + (S_IREAD >> 6));
2577 else
2578 sbufptr->st_mode |= ((S_IREAD|S_IWRITE) + ((S_IREAD|S_IWRITE) >> 3)
2579 + ((S_IREAD|S_IWRITE) >> 6));
2580 }
2581 return rc;
2582#else
ed59ec62 2583 return my_fstat(fd,sbufptr);
2a07f407 2584#endif
0a753a76
PP
2585}
2586
68dc0745
PP
2587DllExport int
2588win32_pipe(int *pfd, unsigned int size, int mode)
0a753a76 2589{
390b85e7 2590 return _pipe(pfd, size, mode);
0a753a76
PP
2591}
2592
8c0134a8
NIS
2593DllExport PerlIO*
2594win32_popenlist(const char *mode, IV narg, SV **args)
2595{
2596 dTHX;
2597 Perl_croak(aTHX_ "List form of pipe open not implemented");
2598 return NULL;
2599}
2600
50892819
GS
2601/*
2602 * a popen() clone that respects PERL5SHELL
00b02797
JH
2603 *
2604 * changed to return PerlIO* rather than FILE * by BKS, 11-11-2000
50892819
GS
2605 */
2606
00b02797 2607DllExport PerlIO*
68dc0745 2608win32_popen(const char *command, const char *mode)
0a753a76 2609{
4b556e6c 2610#ifdef USE_RTL_POPEN
390b85e7 2611 return _popen(command, mode);
50892819
GS
2612#else
2613 int p[2];
2614 int parent, child;
2615 int stdfd, oldfd;
2616 int ourmode;
2617 int childpid;
2618
2619 /* establish which ends read and write */
2620 if (strchr(mode,'w')) {
2621 stdfd = 0; /* stdin */
2622 parent = 1;
2623 child = 0;
2624 }
2625 else if (strchr(mode,'r')) {
2626 stdfd = 1; /* stdout */
2627 parent = 0;
2628 child = 1;
2629 }
2630 else
2631 return NULL;
2632
2633 /* set the correct mode */
2634 if (strchr(mode,'b'))
2635 ourmode = O_BINARY;
2636 else if (strchr(mode,'t'))
2637 ourmode = O_TEXT;
2638 else
2639 ourmode = _fmode & (O_TEXT | O_BINARY);
2640
2641 /* the child doesn't inherit handles */
2642 ourmode |= O_NOINHERIT;
2643
2644 if (win32_pipe( p, 512, ourmode) == -1)
2645 return NULL;
2646
2647 /* save current stdfd */
2648 if ((oldfd = win32_dup(stdfd)) == -1)
2649 goto cleanup;
2650
2651 /* make stdfd go to child end of pipe (implicitly closes stdfd) */
2652 /* stdfd will be inherited by the child */
2653 if (win32_dup2(p[child], stdfd) == -1)
2654 goto cleanup;
2655
2656 /* close the child end in parent */
2657 win32_close(p[child]);
2658
2659 /* start the child */
4f63d024 2660 {
acfe0abc 2661 dTHX;
c5be433b 2662 if ((childpid = do_spawn_nowait((char*)command)) == -1)
4f63d024 2663 goto cleanup;
50892819 2664
4f63d024
GS
2665 /* revert stdfd to whatever it was before */
2666 if (win32_dup2(oldfd, stdfd) == -1)
2667 goto cleanup;
50892819 2668
4f63d024
GS
2669 /* close saved handle */
2670 win32_close(oldfd);
50892819 2671
4755096e 2672 LOCK_FDPID_MUTEX;
4f63d024 2673 sv_setiv(*av_fetch(w32_fdpid, p[parent], TRUE), childpid);
4755096e 2674 UNLOCK_FDPID_MUTEX;
d91d68c1
R
2675
2676 /* set process id so that it can be returned by perl's open() */
2677 PL_forkprocess = childpid;
4f63d024 2678 }
50892819
GS
2679
2680 /* we have an fd, return a file stream */
00b02797 2681 return (PerlIO_fdopen(p[parent], (char *)mode));
50892819
GS
2682
2683cleanup:
2684 /* we don't need to check for errors here */
2685 win32_close(p[0]);
2686 win32_close(p[1]);
2687 if (oldfd != -1) {
2688 win32_dup2(oldfd, stdfd);
2689 win32_close(oldfd);
2690 }
2691 return (NULL);
2692
4b556e6c 2693#endif /* USE_RTL_POPEN */
0a753a76
PP
2694}
2695
50892819
GS
2696/*
2697 * pclose() clone
2698 */
2699
68dc0745 2700DllExport int
00b02797 2701win32_pclose(PerlIO *pf)
0a753a76 2702{
4b556e6c 2703#ifdef USE_RTL_POPEN
390b85e7 2704 return _pclose(pf);
50892819 2705#else
acfe0abc 2706 dTHX;
e17cb2a9
JD
2707 int childpid, status;
2708 SV *sv;
2709
4755096e 2710 LOCK_FDPID_MUTEX;
00b02797 2711 sv = *av_fetch(w32_fdpid, PerlIO_fileno(pf), TRUE);
4755096e 2712
e17cb2a9
JD
2713 if (SvIOK(sv))
2714 childpid = SvIVX(sv);
2715 else
2716 childpid = 0;
50892819
GS
2717
2718 if (!childpid) {
2719 errno = EBADF;
2720 return -1;
2721 }
2722
00b02797
JH
2723#ifdef USE_PERLIO
2724 PerlIO_close(pf);
2725#else
2726 fclose(pf);
2727#endif
e17cb2a9 2728 SvIVX(sv) = 0;
4755096e 2729 UNLOCK_FDPID_MUTEX;
e17cb2a9 2730
0aaad0ff
GS
2731 if (win32_waitpid(childpid, &status, 0) == -1)
2732 return -1;
50892819 2733
0aaad0ff 2734 return status;
50892819 2735
4b556e6c 2736#endif /* USE_RTL_POPEN */
0a753a76 2737}
6b980173
JD
2738
2739static BOOL WINAPI
2740Nt4CreateHardLinkW(
2741 LPCWSTR lpFileName,
2742 LPCWSTR lpExistingFileName,
2743 LPSECURITY_ATTRIBUTES lpSecurityAttributes)
2744{
2745 HANDLE handle;
2746 WCHAR wFullName[MAX_PATH+1];
2747 LPVOID lpContext = NULL;
2748 WIN32_STREAM_ID StreamId;
2749 DWORD dwSize = (char*)&StreamId.cStreamName - (char*)&StreamId;
2750 DWORD dwWritten;
2751 DWORD dwLen;
2752 BOOL bSuccess;
2753
2754 BOOL (__stdcall *pfnBackupWrite)(HANDLE, LPBYTE, DWORD, LPDWORD,
2755 BOOL, BOOL, LPVOID*) =
2756 (BOOL (__stdcall *)(HANDLE, LPBYTE, DWORD, LPDWORD,
2757 BOOL, BOOL, LPVOID*))
2758 GetProcAddress(GetModuleHandle("kernel32.dll"), "BackupWrite");
2759 if (pfnBackupWrite == NULL)
2760 return 0;
2761
2762 dwLen = GetFullPathNameW(lpFileName, MAX_PATH, wFullName, NULL);
2763 if (dwLen == 0)
2764 return 0;
2765 dwLen = (dwLen+1)*sizeof(WCHAR);
2766
2767 handle = CreateFileW(lpExistingFileName, FILE_WRITE_ATTRIBUTES,
2768 FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,
2769 NULL, OPEN_EXISTING, 0, NULL);
2770 if (handle == INVALID_HANDLE_VALUE)
2771 return 0;
2772
2773 StreamId.dwStreamId = BACKUP_LINK;
2774 StreamId.dwStreamAttributes = 0;
2775 StreamId.dwStreamNameSize = 0;
6f24f39d
JK
2776#if defined(__BORLANDC__) \
2777 ||(defined(__MINGW32__) && !defined(_ANONYMOUS_UNION))
4ce4f76e
GS
2778 StreamId.Size.u.HighPart = 0;
2779 StreamId.Size.u.LowPart = dwLen;
2780#else
6b980173
JD
2781 StreamId.Size.HighPart = 0;
2782 StreamId.Size.LowPart = dwLen;
4ce4f76e 2783#endif
6b980173
JD
2784
2785 bSuccess = pfnBackupWrite(handle, (LPBYTE)&StreamId, dwSize, &dwWritten,
2786 FALSE, FALSE, &lpContext);
2787 if (bSuccess) {
2788 bSuccess = pfnBackupWrite(handle, (LPBYTE)wFullName, dwLen, &dwWritten,
2789 FALSE, FALSE, &lpContext);
2790 pfnBackupWrite(handle, NULL, 0, &dwWritten, TRUE, FALSE, &lpContext);
2791 }
2792
2793 CloseHandle(handle);
2794 return bSuccess;
2795}
2796
2797DllExport int
2798win32_link(const char *oldname, const char *newname)
2799{
acfe0abc 2800 dTHX;
6b980173 2801 BOOL (__stdcall *pfnCreateHardLinkW)(LPCWSTR,LPCWSTR,LPSECURITY_ATTRIBUTES);
82867ecf
GS
2802 WCHAR wOldName[MAX_PATH+1];
2803 WCHAR wNewName[MAX_PATH+1];
6b980173
JD
2804
2805 if (IsWin95())
1be9d9c6 2806 Perl_croak(aTHX_ PL_no_func, "link");
6b980173
JD
2807
2808 pfnCreateHardLinkW =
2809 (BOOL (__stdcall *)(LPCWSTR, LPCWSTR, LPSECURITY_ATTRIBUTES))
2810 GetProcAddress(GetModuleHandle("kernel32.dll"), "CreateHardLinkW");
2811 if (pfnCreateHardLinkW == NULL)
2812 pfnCreateHardLinkW = Nt4CreateHardLinkW;
2813
2814 if ((A2WHELPER(oldname, wOldName, sizeof(wOldName))) &&
2815 (A2WHELPER(newname, wNewName, sizeof(wNewName))) &&
7766f137
GS
2816 (wcscpy(wOldName, PerlDir_mapW(wOldName)),
2817 pfnCreateHardLinkW(PerlDir_mapW(wNewName), wOldName, NULL)))
6b980173
JD
2818 {
2819 return 0;
2820 }
2821 errno = (GetLastError() == ERROR_FILE_NOT_FOUND) ? ENOENT : EINVAL;
2822 return -1;
2823}
0a753a76 2824
68dc0745 2825DllExport int
8d9b2e3c 2826win32_rename(const char *oname, const char *newname)
e24c7c18 2827{
65cb15a1
GS
2828 WCHAR wOldName[MAX_PATH+1];
2829 WCHAR wNewName[MAX_PATH+1];
2830 char szOldName[MAX_PATH+1];
2831 char szNewName[MAX_PATH+1];
7fac1903 2832 BOOL bResult;
acfe0abc 2833 dTHX;
65cb15a1 2834
80252599
GS
2835 /* XXX despite what the documentation says about MoveFileEx(),
2836 * it doesn't work under Windows95!
2837 */
2838 if (IsWinNT()) {
65cb15a1 2839 DWORD dwFlags = MOVEFILE_COPY_ALLOWED;
7fac1903 2840 if (USING_WIDE()) {
0cb96387
GS
2841 A2WHELPER(oname, wOldName, sizeof(wOldName));
2842 A2WHELPER(newname, wNewName, sizeof(wNewName));
65cb15a1
GS
2843 if (wcsicmp(wNewName, wOldName))
2844 dwFlags |= MOVEFILE_REPLACE_EXISTING;
7766f137 2845 wcscpy(wOldName, PerlDir_mapW(wOldName));
65cb15a1 2846 bResult = MoveFileExW(wOldName,PerlDir_mapW(wNewName), dwFlags);
7fac1903
GS
2847 }
2848 else {
65cb15a1
GS
2849 if (stricmp(newname, oname))
2850 dwFlags |= MOVEFILE_REPLACE_EXISTING;
2851 strcpy(szOldName, PerlDir_mapA(oname));
2852 bResult = MoveFileExA(szOldName,PerlDir_mapA(newname), dwFlags);
7fac1903
GS
2853 }
2854 if (!bResult) {
80252599
GS
2855 DWORD err = GetLastError();
2856 switch (err) {
2857 case ERROR_BAD_NET_NAME:
2858 case ERROR_BAD_NETPATH:
2859 case ERROR_BAD_PATHNAME:
2860 case ERROR_FILE_NOT_FOUND:
2861 case ERROR_FILENAME_EXCED_RANGE:
2862 case ERROR_INVALID_DRIVE:
2863 case ERROR_NO_MORE_FILES:
2864 case ERROR_PATH_NOT_FOUND:
2865 errno = ENOENT;
2866 break;
2867 default:
2868 errno = EACCES;
2869 break;
2870 }
2871 return -1;
2872 }
2873 return 0;
e24c7c18 2874 }
80252599
GS
2875 else {
2876 int retval = 0;
65cb15a1 2877 char szTmpName[MAX_PATH+1];
80252599
GS
2878 char dname[MAX_PATH+1];
2879 char *endname = Nullch;
2880 STRLEN tmplen = 0;
2881 DWORD from_attr, to_attr;
2882
65cb15a1
GS
2883 strcpy(szOldName, PerlDir_mapA(oname));
2884 strcpy(szNewName, PerlDir_mapA(newname));
2885
80252599 2886 /* if oname doesn't exist, do nothing */
65cb15a1 2887 from_attr = GetFileAttributes(szOldName);
80252599
GS
2888 if (from_attr == 0xFFFFFFFF) {
2889 errno = ENOENT;
2890 return -1;
2891 }
2892
2893 /* if newname exists, rename it to a temporary name so that we
2894 * don't delete it in case oname happens to be the same file
2895 * (but perhaps accessed via a different path)
2896 */
65cb15a1 2897 to_attr = GetFileAttributes(szNewName);
80252599
GS
2898 if (to_attr != 0xFFFFFFFF) {
2899 /* if newname is a directory, we fail
2900 * XXX could overcome this with yet more convoluted logic */
2901 if (to_attr & FILE_ATTRIBUTE_DIRECTORY) {
2902 errno = EACCES;
2903 return -1;
2904 }
65cb15a1
GS
2905 tmplen = strlen(szNewName);
2906 strcpy(szTmpName,szNewName);
2907 endname = szTmpName+tmplen;
2908 for (; endname > szTmpName ; --endname) {
80252599
GS
2909 if (*endname == '/' || *endname == '\\') {
2910 *endname = '\0';
2911 break;
2912 }
2913 }
65cb15a1
GS
2914 if (endname > szTmpName)
2915 endname = strcpy(dname,szTmpName);
e24c7c18 2916 else
80252599
GS
2917 endname = ".";
2918
2919 /* get a temporary filename in same directory
2920 * XXX is this really the best we can do? */
65cb15a1 2921 if (!GetTempFileName((LPCTSTR)endname, "plr", 0, szTmpName)) {
80252599
GS
2922 errno = ENOENT;
2923 return -1;
2924 }
65cb15a1 2925 DeleteFile(szTmpName);
80252599 2926
65cb15a1 2927 retval = rename(szNewName, szTmpName);
80252599
GS
2928 if (retval != 0) {
2929 errno = EACCES;
2930 return retval;
e24c7c18
GS
2931 }
2932 }
80252599
GS
2933
2934 /* rename oname to newname */
65cb15a1 2935 retval = rename(szOldName, szNewName);
80252599
GS
2936
2937 /* if we created a temporary file before ... */
2938 if (endname != Nullch) {
2939 /* ...and rename succeeded, delete temporary file/directory */
2940 if (retval == 0)
65cb15a1 2941 DeleteFile(szTmpName);
80252599
GS
2942 /* else restore it to what it was */
2943 else
65cb15a1 2944 (void)rename(szTmpName, szNewName);
80252599
GS
2945 }
2946 return retval;
e24c7c18 2947 }
e24c7c18
GS
2948}
2949
2950DllExport int
68dc0745 2951win32_setmode(int fd, int mode)
0a753a76 2952{
390b85e7 2953 return setmode(fd, mode);
0a753a76
PP
2954}
2955
96e4d5b1
PP
2956DllExport long
2957win32_lseek(int fd, long offset, int origin)
2958{
390b85e7 2959 return lseek(fd, offset, origin);
96e4d5b1
PP
2960}
2961
2962DllExport long
2963win32_tell(int fd)
2964{
390b85e7 2965 return tell(fd);
96e4d5b1
PP
2966}
2967
68dc0745
PP
2968DllExport int
2969win32_open(const char *path, int flag, ...)
0a753a76 2970{
acfe0abc 2971 dTHX;
68dc0745
PP
2972 va_list ap;
2973 int pmode;
82867ecf 2974 WCHAR wBuffer[MAX_PATH+1];
0a753a76
PP
2975
2976 va_start(ap, flag);
2977 pmode = va_arg(ap, int);
2978 va_end(ap);
2979
68dc0745 2980 if (stricmp(path, "/dev/null")==0)
7fac1903
GS
2981 path = "NUL";
2982
2983 if (USING_WIDE()) {
0cb96387 2984 A2WHELPER(path, wBuffer, sizeof(wBuffer));
7766f137 2985 return _wopen(PerlDir_mapW(wBuffer), flag, pmode);
7fac1903 2986 }
7766f137 2987 return open(PerlDir_mapA(path), flag, pmode);
0a753a76
PP
2988}
2989
00b02797
JH
2990/* close() that understands socket */
2991extern int my_close(int); /* in win32sck.c */
2992
68dc0745
PP
2993DllExport int
2994win32_close(int fd)
0a753a76 2995{
00b02797 2996 return my_close(fd);
0a753a76
PP
2997}
2998
68dc0745 2999DllExport int
96e4d5b1
PP
3000win32_eof(int fd)
3001{
390b85e7 3002 return eof(fd);
96e4d5b1
PP
3003}
3004
3005DllExport int
68dc0745 3006win32_dup(int fd)
0a753a76 3007{
390b85e7 3008 return dup(fd);
0a753a76
PP
3009}
3010
68dc0745
PP
3011DllExport int
3012win32_dup2(int fd1,int fd2)
0a753a76 3013{
390b85e7 3014 return dup2(fd1,fd2);
0a753a76
PP
3015}
3016
f7aeb604
GS
3017#ifdef PERL_MSVCRT_READFIX
3018
3019#define LF 10 /* line feed */
3020#define CR 13 /* carriage return */
3021#define CTRLZ 26 /* ctrl-z means eof for text */
3022#define FOPEN 0x01 /* file handle open */
3023#define FEOFLAG 0x02 /* end of file has been encountered */
3024#define FCRLF 0x04 /* CR-LF across read buffer (in text mode) */
3025#define FPIPE 0x08 /* file handle refers to a pipe */
3026#define FAPPEND 0x20 /* file handle opened O_APPEND */
3027#define FDEV 0x40 /* file handle refers to device */
3028#define FTEXT 0x80 /* file handle is in text mode */
3029#define MAX_DESCRIPTOR_COUNT (64*32) /* this is the maximun that MSVCRT can handle */
3030
b181b6fb
GS
3031int __cdecl
3032_fixed_read(int fh, void *buf, unsigned cnt)
f7aeb604
GS
3033{
3034 int bytes_read; /* number of bytes read */
3035 char *buffer; /* buffer to read to */
3036 int os_read; /* bytes read on OS call */
3037 char *p, *q; /* pointers into buffer */
3038 char peekchr; /* peek-ahead character */
3039 ULONG filepos; /* file position after seek */
3040 ULONG dosretval; /* o.s. return value */
3041
3042 /* validate handle */
3043 if (((unsigned)fh >= (unsigned)MAX_DESCRIPTOR_COUNT) ||
3044 !(_osfile(fh) & FOPEN))
3045 {
3046 /* out of range -- return error */
3047 errno = EBADF;
3048 _doserrno = 0; /* not o.s. error */
3049 return -1;
3050 }
3051
635bbe87
GS
3052 /*
3053 * If lockinitflag is FALSE, assume fd is device
3054 * lockinitflag is set to TRUE by open.
3055 */
3056 if (_pioinfo(fh)->lockinitflag)
3057 EnterCriticalSection(&(_pioinfo(fh)->lock)); /* lock file */
f7aeb604
GS
3058
3059 bytes_read = 0; /* nothing read yet */
3060 buffer = (char*)buf;
3061
3062 if (cnt == 0 || (_osfile(fh) & FEOFLAG)) {
3063 /* nothing to read or at EOF, so return 0 read */
3064 goto functionexit;
3065 }
3066
3067 if ((_osfile(fh) & (FPIPE|FDEV)) && _pipech(fh) != LF) {
3068 /* a pipe/device and pipe lookahead non-empty: read the lookahead
3069 * char */
3070 *buffer++ = _pipech(fh);
3071 ++bytes_read;
3072 --cnt;
3073 _pipech(fh) = LF; /* mark as empty */
3074 }
3075
3076 /* read the data */
3077
3078 if (!ReadFile((HANDLE)_osfhnd(fh), buffer, cnt, (LPDWORD)&os_read, NULL))
3079 {
3080 /* ReadFile has reported an error. recognize two special cases.
3081 *
3082 * 1. map ERROR_ACCESS_DENIED to EBADF
3083 *
3084 * 2. just return 0 if ERROR_BROKEN_PIPE has occurred. it
3085 * means the handle is a read-handle on a pipe for which
3086 * all write-handles have been closed and all data has been
3087 * read. */
3088
3089 if ((dosretval = GetLastError()) == ERROR_ACCESS_DENIED) {
3090 /* wrong read/write mode should return EBADF, not EACCES */
3091 errno = EBADF;
3092 _doserrno = dosretval;
3093 bytes_read = -1;
3094 goto functionexit;
3095 }
3096 else if (dosretval == ERROR_BROKEN_PIPE) {
3097 bytes_read = 0;
3098 goto functionexit;
3099 }
3100 else {
3101 bytes_read = -1;
3102 goto functionexit;
3103 }
3104 }
3105
3106 bytes_read += os_read; /* update bytes read */
3107
3108 if (_osfile(fh) & FTEXT) {
3109 /* now must translate CR-LFs to LFs in the buffer */
3110
3111 /* set CRLF flag to indicate LF at beginning of buffer */
3112 /* if ((os_read != 0) && (*(char *)buf == LF)) */
3113 /* _osfile(fh) |= FCRLF; */
3114 /* else */
3115 /* _osfile(fh) &= ~FCRLF; */
3116
3117 _osfile(fh) &= ~FCRLF;
3118
3119 /* convert chars in the buffer: p is src, q is dest */
3120 p = q = (char*)buf;
3121 while (p < (char *)buf + bytes_read) {
3122 if (*p == CTRLZ) {
3123 /* if fh is not a device, set ctrl-z flag */
3124 if (!(_osfile(fh) & FDEV))
3125 _osfile(fh) |= FEOFLAG;
3126 break; /* stop translating */
3127 }
3128 else if (*p != CR)
3129 *q++ = *p++;
3130 else {
3131 /* *p is CR, so must check next char for LF */
3132 if (p < (char *)buf + bytes_read - 1) {
3133 if (*(p+1) == LF) {
3134 p += 2;
3135 *q++ = LF; /* convert CR-LF to LF */
3136 }
3137 else
3138 *q++ = *p++; /* store char normally */
3139 }
3140 else {
3141 /* This is the hard part. We found a CR at end of
3142 buffer. We must peek ahead to see if next char
3143 is an LF. */
3144 ++p;
3145
3146 dosretval = 0;
3147 if (!ReadFile((HANDLE)_osfhnd(fh), &peekchr, 1,
3148 (LPDWORD)&os_read, NULL))
3149 dosretval = GetLastError();
3150
3151 if (dosretval != 0 || os_read == 0) {
3152 /* couldn't read ahead, store CR */
3153 *q++ = CR;
3154 }
3155 else {
3156 /* peekchr now has the extra character -- we now
3157 have several possibilities:
3158 1. disk file and char is not LF; just seek back
3159 and copy CR
3160 2. disk file and char is LF; store LF, don't seek back
3161 3. pipe/device and char is LF; store LF.
3162 4. pipe/device and char isn't LF, store CR and
3163 put char in pipe lookahead buffer. */
3164 if (_osfile(fh) & (FDEV|FPIPE)) {
3165 /* non-seekable device */
3166 if (peekchr == LF)
3167 *q++ = LF;
3168 else {
3169 *q++ = CR;
3170 _pipech(fh) = peekchr;
3171 }
3172 }
3173 else {
3174 /* disk file */
3175 if (peekchr == LF) {
3176 /* nothing read yet; must make some
3177 progress */
3178 *q++ = LF;
3179 /* turn on this flag for tell routine */
3180 _osfile(fh) |= FCRLF;
3181 }
3182 else {
3183 HANDLE osHandle; /* o.s. handle value */
3184 /* seek back */
3185 if ((osHandle = (HANDLE)_get_osfhandle(fh)) != (HANDLE)-1)
3186 {
3187 if ((filepos = SetFilePointer(osHandle, -1, NULL, FILE_CURRENT)) == -1)
3188 dosretval = GetLastError();
3189 }
3190 if (peekchr != LF)
3191 *q++ = CR;
3192 }
3193 }
3194 }
3195 }
3196 }
3197 }
3198
3199 /* we now change bytes_read to reflect the true number of chars
3200 in the buffer */
3201 bytes_read = q - (char *)buf;
3202 }
3203
3fadfdf1 3204functionexit:
635bbe87
GS
3205 if (_pioinfo(fh)->lockinitflag)
3206 LeaveCriticalSection(&(_pioinfo(fh)->lock)); /* unlock file */
f7aeb604
GS
3207
3208 return bytes_read;
3209}
3210
3211#endif /* PERL_MSVCRT_READFIX */
3212
68dc0745 3213DllExport int
3e3baf6d 3214win32_read(int fd, void *buf, unsigned int cnt)
0a753a76 3215{
f7aeb604
GS
3216#ifdef PERL_MSVCRT_READFIX
3217 return _fixed_read(fd, buf, cnt);
3218#else
390b85e7 3219 return read(fd, buf, cnt);
f7aeb604 3220#endif
0a753a76
PP
3221}
3222
68dc0745 3223DllExport int
3e3baf6d 3224win32_write(int fd, const void *buf, unsigned int cnt)
0a753a76 3225{
390b85e7 3226 return write(fd, buf, cnt);
0a753a76
PP
3227}
3228
68dc0745 3229DllExport int
5aabfad6
PP
3230win32_mkdir(const char *dir, int mode)
3231{
acfe0abc 3232 dTHX;
7766f137 3233 if (USING_WIDE()) {
82867ecf 3234 WCHAR wBuffer[MAX_PATH+1];
7766f137
GS
3235 A2WHELPER(dir, wBuffer, sizeof(wBuffer));
3236 return _wmkdir(PerlDir_mapW(wBuffer));
3237 }
3238 return mkdir(PerlDir_mapA(dir)); /* just ignore mode */
5aabfad6 3239}
96e4d5b1 3240
5aabfad6
PP
3241DllExport int
3242win32_rmdir(const char *dir)
3243{
acfe0abc 3244 dTHX;
7766f137 3245 if (USING_WIDE()) {
82867ecf 3246 WCHAR wBuffer[MAX_PATH+1];
7766f137
GS
3247 A2WHELPER(dir, wBuffer, sizeof(wBuffer));
3248 return _wrmdir(PerlDir_mapW(wBuffer));
3249 }
3250 return rmdir(PerlDir_mapA(dir));
5aabfad6 3251}
96e4d5b1 3252
5aabfad6
PP
3253DllExport int
3254win32_chdir(const char *dir)
3255{
4ae93879 3256 dTHX;
9ec3348a
JH
3257 if (!dir) {
3258 errno = ENOENT;
3259 return -1;
3260 }
7766f137 3261 if (USING_WIDE()) {
82867ecf 3262 WCHAR wBuffer[MAX_PATH+1];
7766f137
GS
3263 A2WHELPER(dir, wBuffer, sizeof(wBuffer));
3264 return _wchdir(wBuffer);
3265 }
390b85e7 3266 return chdir(dir);
5aabfad6 3267}
96e4d5b1 3268
7766f137
GS
3269DllExport int
3270win32_access(const char *path, int mode)
3271{
acfe0abc 3272 dTHX;
7766f137 3273 if (USING_WIDE()) {
82867ecf 3274 WCHAR wBuffer[MAX_PATH+1];
7766f137
GS
3275 A2WHELPER(path, wBuffer, sizeof(wBuffer));
3276 return _waccess(PerlDir_mapW(wBuffer), mode);
3277 }
3278 return access(PerlDir_mapA(path), mode);
3279}
3280
3281DllExport int
3282win32_chmod(const char *path, int mode)
3283{
acfe0abc 3284 dTHX;
7766f137 3285 if (USING_WIDE()) {
82867ecf 3286 WCHAR wBuffer[MAX_PATH+1];
7766f137
GS
3287 A2WHELPER(path, wBuffer, sizeof(wBuffer));
3288 return _wchmod(PerlDir_mapW(wBuffer), mode);
3289 }
3290 return chmod(PerlDir_mapA(path), mode);
3291}
3292
3293
0aaad0ff 3294static char *
dd7038b3 3295create_command_line(char *cname, STRLEN clen, const char * const *args)
0aaad0ff 3296{
acfe0abc 3297 dTHX;
b309b8ae
JH
3298 int index, argc;
3299 char *cmd, *ptr;
3300 const char *arg;
3301 STRLEN len = 0;
81bc1258 3302 bool bat_file = FALSE;
b309b8ae 3303 bool cmd_shell = FALSE;
7b11e424 3304 bool dumb_shell = FALSE;
b309b8ae 3305 bool extra_quotes = FALSE;
dd7038b3 3306 bool quote_next = FALSE;
81bc1258
JH
3307
3308 if (!cname)
3309 cname = (char*)args[0];
b309b8ae
JH
3310
3311 /* The NT cmd.exe shell has the following peculiarity that needs to be
3312 * worked around. It strips a leading and trailing dquote when any
3313 * of the following is true:
3314 * 1. the /S switch was used
3315 * 2. there are more than two dquotes
3316 * 3. there is a special character from this set: &<>()@^|
3317 * 4. no whitespace characters within the two dquotes
3318 * 5. string between two dquotes isn't an executable file
3319 * To work around this, we always add a leading and trailing dquote
3320 * to the string, if the first argument is either "cmd.exe" or "cmd",
3321 * and there were at least two or more arguments passed to cmd.exe
3322 * (not including switches).
dd7038b3
JH
3323 * XXX the above rules (from "cmd /?") don't seem to be applied
3324 * always, making for the convolutions below :-(
b309b8ae 3325 */
81bc1258 3326 if (cname) {
dd7038b3
JH
3327 if (!clen)
3328 clen = strlen(cname);
3329
81bc1258
JH
3330 if (clen > 4
3331 && (stricmp(&cname[clen-4], ".bat") == 0
3332 || (IsWinNT() && stricmp(&cname[clen-4], ".cmd") == 0)))
3333 {
3334 bat_file = TRUE;
3335 len += 3;
3336 }
dd7038b3
JH
3337 else {
3338 char *exe = strrchr(cname, '/');
3339 char *exe2 = strrchr(cname, '\\');
3340 if (exe2 > exe)
3341 exe = exe2;
3342 if (exe)
3343 ++exe;
3344 else
3345 exe = cname;
3346 if (stricmp(exe, "cmd.exe") == 0 || stricmp(exe, "cmd") == 0) {
3347 cmd_shell = TRUE;
3348 len += 3;
3349 }
7b11e424
JH
3350 else if (stricmp(exe, "command.com") == 0
3351 || stricmp(exe, "command") == 0)
3352 {
3353 dumb_shell = TRUE;
3354 }
81bc1258 3355 }
b309b8ae 3356 }
0aaad0ff 3357
b309b8ae
JH
3358 DEBUG_p(PerlIO_printf(Perl_debug_log, "Args "));
3359 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3360 STRLEN curlen = strlen(arg);
3361 if (!(arg[0] == '"' && arg[curlen-1] == '"'))
3362 len += 2; /* assume quoting needed (worst case) */
3363 len += curlen + 1;
3364 DEBUG_p(PerlIO_printf(Perl_debug_log, "[%s]",arg));
3365 }
3366 DEBUG_p(PerlIO_printf(Perl_debug_log, "\n"));
0aaad0ff 3367
b309b8ae 3368 argc = index;
0aaad0ff
GS
3369 New(1310, cmd, len, char);
3370 ptr = cmd;
0aaad0ff 3371
81bc1258
JH
3372 if (bat_file) {
3373 *ptr++ = '"';
3374 extra_quotes = TRUE;
3375 }
3376
0aaad0ff 3377 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
b309b8ae
JH
3378 bool do_quote = 0;
3379 STRLEN curlen = strlen(arg);
3380
81bc1258
JH
3381 /* we want to protect empty arguments and ones with spaces with
3382 * dquotes, but only if they aren't already there */
7b11e424
JH
3383 if (!dumb_shell) {
3384 if (!curlen) {
3385 do_quote = 1;
3386 }
02ef22d5
JH
3387 else if (quote_next) {
3388 /* see if it really is multiple arguments pretending to
3389 * be one and force a set of quotes around it */
3390 if (*find_next_space(arg))
3391 do_quote = 1;
3392 }
7b11e424
JH
3393 else if (!(arg[0] == '"' && curlen > 1 && arg[curlen-1] == '"')) {
3394 STRLEN i = 0;
3395 while (i < curlen) {
3396 if (isSPACE(arg[i])) {
3397 do_quote = 1;
02ef22d5
JH
3398 }
3399 else if (arg[i] == '"') {
3400 do_quote = 0;
7b11e424
JH
3401 break;
3402 }
3403 i++;
b309b8ae 3404 }
b309b8ae 3405 }
dd7038b3 3406 }
b309b8ae
JH
3407
3408 if (do_quote)
3409 *ptr++ = '"';
3410
18a945d4 3411 strcpy(ptr, arg);
b309b8ae
JH
3412 ptr += curlen;
3413
3414 if (do_quote)
3415 *ptr++ = '"';
3416
3417 if (args[index+1])
3418 *ptr++ = ' ';
3419
81bc1258
JH
3420 if (!extra_quotes
3421 && cmd_shell
dd7038b3 3422 && (stricmp(arg, "/x/c") == 0 || stricmp(arg, "/c") == 0))
b309b8ae 3423 {
dd7038b3
JH
3424 /* is there a next argument? */
3425 if (args[index+1]) {
3426 /* are there two or more next arguments? */
3427 if (args[index+2]) {
3428 *ptr++ = '"';
3429 extra_quotes = TRUE;
3430 }
3431 else {
02ef22d5 3432 /* single argument, force quoting if it has spaces */
dd7038b3
JH
3433 quote_next = TRUE;
3434 }
3435 }
b309b8ae 3436 }
0aaad0ff
GS
3437 }
3438
b309b8ae
JH
3439 if (extra_quotes)
3440 *ptr++ = '"';
3441
3442 *ptr = '\0';
3443
0aaad0ff
GS
3444 return cmd;
3445}
3446
3447static char *
3448qualified_path(const char *cmd)
3449{
acfe0abc 3450 dTHX;
0aaad0ff
GS
3451 char *pathstr;
3452 char *fullcmd, *curfullcmd;
3453 STRLEN cmdlen = 0;
3454 int has_slash = 0;
3455
3456 if (!cmd)
3457 return Nullch;
3458 fullcmd = (char*)cmd;
3459 while (*fullcmd) {
3460 if (*fullcmd == '/' || *fullcmd == '\\')
3461 has_slash++;
3462 fullcmd++;
3463 cmdlen++;
3464 }
3465
3466 /* look in PATH */
2fb9ab56 3467 pathstr = PerlEnv_getenv("PATH");
0aaad0ff
GS
3468 New(0, fullcmd, MAX_PATH+1, char);
3469 curfullcmd = fullcmd;
3470
3471 while (1) {
3472 DWORD res;
3473
3474 /* start by appending the name to the current prefix */
3475 strcpy(curfullcmd, cmd);
3476 curfullcmd += cmdlen;
3477
3478 /* if it doesn't end with '.', or has no extension, try adding
3479 * a trailing .exe first */
3480 if (cmd[cmdlen-1] != '.'
3481 && (cmdlen < 4 || cmd[cmdlen-4] != '.'))
3482 {
3483 strcpy(curfullcmd, ".exe");
3484 res = GetFileAttributes(fullcmd);
3485 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3486 return fullcmd;
3487 *curfullcmd = '\0';
3488 }
3489
3490 /* that failed, try the bare name */
3491 res = GetFileAttributes(fullcmd);
3492 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3493 return fullcmd;
3494
3495 /* quit if no other path exists, or if cmd already has path */
3496 if (!pathstr || !*pathstr || has_slash)
3497 break;
3498
3499 /* skip leading semis */
3500 while (*pathstr == ';')
3501 pathstr++;
3502
3503 /* build a new prefix from scratch */
3504 curfullcmd = fullcmd;
3505 while (*pathstr && *pathstr != ';') {
3506 if (*pathstr == '"') { /* foo;"baz;etc";bar */
3507 pathstr++; /* skip initial '"' */
3508 while (*pathstr && *pathstr != '"') {
3509 if (curfullcmd-fullcmd < MAX_PATH-cmdlen-5)
3510 *curfullcmd++ = *pathstr;
3511 pathstr++;
3512 }
3513 if (*pathstr)
3514 pathstr++; /* skip trailing '"' */
3515 }
3516 else {
3517 if (curfullcmd-fullcmd < MAX_PATH-cmdlen-5)
3518 *curfullcmd++ = *pathstr;
3519 pathstr++;
3520 }
3521 }
3522 if (*pathstr)
3523 pathstr++; /* skip trailing semi */
3524 if (curfullcmd > fullcmd /* append a dir separator */
3525 && curfullcmd[-1] != '/' && curfullcmd[-1] != '\\')
3526 {
3527 *curfullcmd++ = '\\';
3528 }
3529 }
3530GIVE_UP:
3531 Safefree(fullcmd);
3532 return Nullch;
3533}
3534
3075ddba
GS
3535/* The following are just place holders.
3536 * Some hosts may provide and environment that the OS is
3537 * not tracking, therefore, these host must provide that
3538 * environment and the current directory to CreateProcess
3539 */
3540
df3728a2
JH
3541DllExport void*
3542win32_get_childenv(void)
3075ddba
GS
3543{
3544 return NULL;
3545}
3546
df3728a2
JH
3547DllExport void
3548win32_free_childenv(void* d)
3075ddba
GS
3549{
3550}
3551
df3728a2
JH
3552DllExport void
3553win32_clearenv(void)
3554{
3555 char *envv = GetEnvironmentStrings();
3556 char *cur = envv;
3557 STRLEN len;
3558 while (*cur) {
3559 char *end = strchr(cur,'=');
3560 if (end && end != cur) {
3561 *end = '\0';
3562 SetEnvironmentVariable(cur, NULL);
3563 *end = '=';
3564 cur = end + strlen(end+1)+2;
3565 }
3566 else if ((len = strlen(cur)))
3567 cur += len+1;
3568 }
3569 FreeEnvironmentStrings(envv);
3570}
3571
3572DllExport char*
3573win32_get_childdir(void)
3075ddba 3574{
acfe0abc 3575 dTHX;
7766f137
GS
3576 char* ptr;
3577 char szfilename[(MAX_PATH+1)*2];
3578 if (USING_WIDE()) {
3579 WCHAR wfilename[MAX_PATH+1];
3580 GetCurrentDirectoryW(MAX_PATH+1, wfilename);
3581 W2AHELPER(wfilename, szfilename, sizeof(szfilename));
3582 }
3583 else {
3584 GetCurrentDirectoryA(MAX_PATH+1, szfilename);
3585 }
3586
3587 New(0, ptr, strlen(szfilename)+1, char);
3588 strcpy(ptr, szfilename);
3589 return ptr;
3075ddba
GS
3590}
3591
df3728a2
JH
3592DllExport void
3593win32_free_childdir(char* d)
3075ddba 3594{
acfe0abc 3595 dTHX;
7766f137 3596 Safefree(d);
3075ddba
GS
3597}
3598
3599
0aaad0ff
GS
3600/* XXX this needs to be made more compatible with the spawnvp()
3601 * provided by the various RTLs. In particular, searching for
3602 * *.{com,bat,cmd} files (as done by the RTLs) is unimplemented.
3603 * This doesn't significantly affect perl itself, because we
3604 * always invoke things using PERL5SHELL if a direct attempt to
3605 * spawn the executable fails.
3fadfdf1 3606 *
0aaad0ff
GS
3607 * XXX splitting and rejoining the commandline between do_aspawn()
3608 * and win32_spawnvp() could also be avoided.
3609 */
3610
5aabfad6 3611DllExport int
3e3baf6d 3612win32_spawnvp(int mode, const char *cmdname, const char *const *argv)
0a753a76 3613{
0aaad0ff
GS
3614#ifdef USE_RTL_SPAWNVP
3615 return spawnvp(mode, cmdname, (char * const *)argv);
3616#else
acfe0abc 3617 dTHX;
2b260de0 3618 int ret;
3075ddba
GS
3619 void* env;
3620 char* dir;
635bbe87 3621 child_IO_table tbl;
0aaad0ff
GS
3622 STARTUPINFO StartupInfo;
3623 PROCESS_INFORMATION ProcessInformation;
3624 DWORD create = 0;
dd7038b3 3625 char *cmd;
0aaad0ff 3626 char *fullcmd = Nullch;