This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Win32 signal emulation cleanup.
[perl5.git] / win32 / win32.c
CommitLineData
68dc0745 1/* WIN32.C
2 *
3fadfdf1 3 * (c) 1995 Microsoft Corporation. All rights reserved.
68dc0745 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 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 29#if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
30#define PerlIO FILE
31#endif
32
7a9ec5a3 33#include <sys/stat.h>
0a753a76 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 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 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 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 355 case '\'':
356 case '\"':
9404a519
GS		 357 if (inquote) {
358 if (quote == *ptr) {
68dc0745 359 inquote = 0;
360 quote = '\0';
0a753a76 361 }
68dc0745 362 }
363 else {
364 quote = *ptr;
365 inquote++;
366 }
367 break;
368 case '>':
369 case '<':
370 case '|':
9404a519 371 if (!inquote)
68dc0745 372 return TRUE;
373 default:
374 break;
0a753a76 375 }
68dc0745 376 ++ptr;
377 }
378 return FALSE;
0a753a76 379}
380
32e30700 381#if !defined(PERL_IMPLICIT_SYS)
68dc0745 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 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 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 406}
407
68dc0745 408long
4f63d024 409Perl_my_pclose(pTHX_ PerlIO *fp)
0a753a76 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 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 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 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 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
PM		 577 if (ckWARN(WARN_EXEC))
578 Perl_warner(aTHX_ 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 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 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 627 New(1301,argv, strlen(cmd) / 2 + 2, char*);
628 New(1302,cmd2, strlen(cmd) + 1, char);
68dc0745 629 strcpy(cmd2, cmd);
630 a = argv;
631 for (s = cmd2; *s;) {
de030af3 632 while (*s && isSPACE(*s))
68dc0745 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 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
PM		 692 if (ckWARN(WARN_EXEC))
693 Perl_warner(aTHX_ 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 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 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 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 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 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 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 820}
821
822
68dc0745 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 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 885 else
886 return NULL;
0a753a76 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 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 904}
905
68dc0745 906/* Rewinddir resets the string pointer to the start */
c5be433b 907DllExport void
ce2e26e5 908win32_rewinddir(DIR *dirp)
0a753a76 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 920 Safefree(dirp->start);
921 Safefree(dirp);
68dc0745 922 return 1;
0a753a76 923}
924
925
68dc0745 926/*
927 * various stubs
928 */
0a753a76 929
930
68dc0745 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 936
937#define ROOT_UID ((uid_t)0)
938#define ROOT_GID ((gid_t)0)
939
68dc0745 940uid_t
941getuid(void)
0a753a76 942{
68dc0745 943 return ROOT_UID;
0a753a76 944}
945
68dc0745 946uid_t
947geteuid(void)
0a753a76 948{
68dc0745 949 return ROOT_UID;
0a753a76 950}
951
68dc0745 952gid_t
953getgid(void)
0a753a76 954{
68dc0745 955 return ROOT_GID;
0a753a76 956}
957
68dc0745 958gid_t
959getegid(void)
0a753a76 960{
68dc0745 961 return ROOT_GID;
0a753a76 962}
963
68dc0745 964int
22239a37 965setuid(uid_t auid)
3fadfdf1 966{
22239a37 967 return (auid == ROOT_UID ? 0 : -1);
0a753a76 968}
969
68dc0745 970int
22239a37 971setgid(gid_t agid)
0a753a76 972{
22239a37 973 return (agid == ROOT_GID ? 0 : -1);
0a753a76 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:
c843839f 1097 /* We fake signals to pseudo-processes using Win32 message queue */
7e5f34c0 1098 if (PostThreadMessage(-pid,WM_USER,sig,0)) {
3fadfdf1 1099 /* It might be us ... */
7e5f34c0
NIS		 1100 PERL_ASYNC_CHECK();
1101 return 0;
1102 }
1103 break;
1104 }
7766f137 1105 }
922b1888
GS		 1106 else if (IsWin95()) {
1107 pid = -pid;
1108 goto alien_process;
1109 }
68dc0745 1110 }
7766f137
GS		 1111 else
1112#endif
1113 {
c66b022d 1114 child = find_pid(pid);
7766f137 1115 if (child >= 0) {
7e5f34c0
NIS		 1116 hProcess = w32_child_handles[child];
1117 switch(sig) {
1118 case 0:
c843839f 1119 /* "Does process exist?" use of kill */
7766f137 1120 return 0;
7e5f34c0
NIS		 1121 case 2:
1122 if (GenerateConsoleCtrlEvent(CTRL_C_EVENT,pid))
1123 return 0;
1124 break;
c843839f 1125 default: /* For now be backwards compatible with perl5.6 */
7e5f34c0
NIS		 1126 case 9:
1127 if (TerminateProcess(hProcess, sig)) {
1128 remove_dead_process(child);
1129 return 0;
1130 }
1131 break;
1132 }
7766f137
GS		 1133 }
1134 else {
922b1888
GS		 1135alien_process:
1136 hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE,
1137 (IsWin95() ? -pid : pid));
42b8b86c 1138 if (hProcess) {
7e5f34c0
NIS		 1139 switch(sig) {
1140 case 0:
c843839f 1141 /* "Does process exist?" use of kill */
42b8b86c 1142 return 0;
7e5f34c0
NIS		 1143 case 2:
1144 if (GenerateConsoleCtrlEvent(CTRL_C_EVENT,pid))
1145 return 0;
1146 break;
c843839f 1147 default: /* For now be backwards compatible with perl5.6 */
7e5f34c0
NIS		 1148 case 9:
1149 if (TerminateProcess(hProcess, sig)) {
1150 CloseHandle(hProcess);
1151 return 0;
1152 }
42b8b86c 1153 }
7766f137
GS		 1154 }
1155 }
1156 }
1157 errno = EINVAL;
1158 return -1;
0a753a76 1159}
fbbbcc48 1160
68dc0745 1161DllExport int
426c1a18 1162win32_stat(const char *path, struct stat *sbuf)
0a753a76 1163{
acfe0abc 1164 dTHX;
3fadfdf1 1165 char buffer[MAX_PATH+1];
68dc0745 1166 int l = strlen(path);
67fbe06e 1167 int res;
82867ecf 1168 WCHAR wbuffer[MAX_PATH+1];
e9ff6d27 1169 WCHAR* pwbuffer;
6b980173
JD		 1170 HANDLE handle;
1171 int nlink = 1;
0a753a76 1172
68dc0745 1173 if (l > 1) {
1174 switch(path[l - 1]) {
e1dbac94
GS		 1175 /* FindFirstFile() and stat() are buggy with a trailing
1176 * backslash, so change it to a forward slash :-( */
68dc0745 1177 case '\\':
426c1a18
GS		 1178 strncpy(buffer, path, l-1);
1179 buffer[l - 1] = '/';
1180 buffer[l] = '\0';
1181 path = buffer;
e1dbac94 1182 break;
23db2e2d 1183 /* FindFirstFile() is buggy with "x:", so add a dot :-( */
e1dbac94
GS		 1184 case ':':
1185 if (l == 2 && isALPHA(path[0])) {
426c1a18
GS		 1186 buffer[0] = path[0];
1187 buffer[1] = ':';
1188 buffer[2] = '.';
1189 buffer[3] = '\0';
e1dbac94 1190 l = 3;
426c1a18 1191 path = buffer;
e1dbac94
GS		 1192 }
1193 break;
68dc0745 1194 }
1195 }
6b980173
JD		 1196
1197 /* We *must* open & close the file once; otherwise file attribute changes */
1198 /* might not yet have propagated to "other" hard links of the same file. */
1199 /* This also gives us an opportunity to determine the number of links. */
7fac1903 1200 if (USING_WIDE()) {
0cb96387 1201 A2WHELPER(path, wbuffer, sizeof(wbuffer));
e9ff6d27
GS		 1202 pwbuffer = PerlDir_mapW(wbuffer);
1203 handle = CreateFileW(pwbuffer, 0, 0, NULL, OPEN_EXISTING, 0, NULL);
7fac1903
GS		 1204 }
1205 else {
e9ff6d27
GS		 1206 path = PerlDir_mapA(path);
1207 l = strlen(path);
1208 handle = CreateFileA(path, 0, 0, NULL, OPEN_EXISTING, 0, NULL);
6b980173
JD		 1209 }
1210 if (handle != INVALID_HANDLE_VALUE) {
1211 BY_HANDLE_FILE_INFORMATION bhi;
1212 if (GetFileInformationByHandle(handle, &bhi))
1213 nlink = bhi.nNumberOfLinks;
1214 CloseHandle(handle);
7fac1903 1215 }
6b980173 1216
e9ff6d27 1217 /* pwbuffer or path will be mapped correctly above */
7766f137 1218 if (USING_WIDE()) {
e9ff6d27 1219 res = _wstat(pwbuffer, (struct _stat *)sbuf);
7766f137
GS		 1220 }
1221 else {
e9ff6d27 1222 res = stat(path, sbuf);
7766f137 1223 }
426c1a18 1224 sbuf->st_nlink = nlink;
6b980173 1225
24caa93f
GS		 1226 if (res < 0) {
1227 /* CRT is buggy on sharenames, so make sure it really isn't.
1228 * XXX using GetFileAttributesEx() will enable us to set
426c1a18 1229 * sbuf->st_*time (but note that's not available on the
24caa93f 1230 * Windows of 1995) */
7fac1903
GS		 1231 DWORD r;
1232 if (USING_WIDE()) {
e9ff6d27 1233 r = GetFileAttributesW(pwbuffer);
7fac1903
GS		 1234 }
1235 else {
e9ff6d27 1236 r = GetFileAttributesA(path);
7fac1903 1237 }
24caa93f 1238 if (r != 0xffffffff && (r & FILE_ATTRIBUTE_DIRECTORY)) {
426c1a18
GS		 1239 /* sbuf may still contain old garbage since stat() failed */
1240 Zero(sbuf, 1, struct stat);
1241 sbuf->st_mode = S_IFDIR | S_IREAD;
24caa93f
GS		 1242 errno = 0;
1243 if (!(r & FILE_ATTRIBUTE_READONLY))
426c1a18 1244 sbuf->st_mode |= S_IWRITE | S_IEXEC;
24caa93f
GS		 1245 return 0;
1246 }
1247 }
24caa93f 1248 else {
e1dbac94
GS		 1249 if (l == 3 && isALPHA(path[0]) && path[1] == ':'
1250 && (path[2] == '\\' || path[2] == '/'))
2293b0e9
AB		 1251 {
1252 /* The drive can be inaccessible, some _stat()s are buggy */
7fac1903 1253 if (USING_WIDE()
e9ff6d27
GS		 1254 ? !GetVolumeInformationW(pwbuffer,NULL,0,NULL,NULL,NULL,NULL,0)
1255 : !GetVolumeInformationA(path,NULL,0,NULL,NULL,NULL,NULL,0)) {
2293b0e9
AB		 1256 errno = ENOENT;
1257 return -1;
1258 }
1259 }
1260#ifdef __BORLANDC__
426c1a18
GS		 1261 if (S_ISDIR(sbuf->st_mode))
1262 sbuf->st_mode |= S_IWRITE | S_IEXEC;
1263 else if (S_ISREG(sbuf->st_mode)) {
d0650a05 1264 int perms;
67fbe06e
GS		 1265 if (l >= 4 && path[l-4] == '.') {
1266 const char *e = path + l - 3;
1267 if (strnicmp(e,"exe",3)
1268 && strnicmp(e,"bat",3)
1269 && strnicmp(e,"com",3)
1270 && (IsWin95() || strnicmp(e,"cmd",3)))
426c1a18 1271 sbuf->st_mode &= ~S_IEXEC;
67fbe06e 1272 else
426c1a18 1273 sbuf->st_mode |= S_IEXEC;
67fbe06e
GS		 1274 }
1275 else
426c1a18 1276 sbuf->st_mode &= ~S_IEXEC;
d0650a05
GS		 1277 /* Propagate permissions to _group_ and _others_ */
1278 perms = sbuf->st_mode & (S_IREAD|S_IWRITE|S_IEXEC);
1279 sbuf->st_mode |= (perms>>3) | (perms>>6);
67fbe06e 1280 }
67fbe06e 1281#endif
2293b0e9 1282 }
67fbe06e 1283 return res;
0a753a76 1284}
1285
8ac9c18d
GS		 1286/* Find the longname of a given path. path is destructively modified.
1287 * It should have space for at least MAX_PATH characters. */
1288DllExport char *
1289win32_longpath(char *path)
1290{
1291 WIN32_FIND_DATA fdata;
1292 HANDLE fhand;
1293 char tmpbuf[MAX_PATH+1];
1294 char *tmpstart = tmpbuf;
1295 char *start = path;
1296 char sep;
1297 if (!path)
1298 return Nullch;
1299
1300 /* drive prefix */
1301 if (isALPHA(path[0]) && path[1] == ':' &&
1302 (path[2] == '/' || path[2] == '\\'))
1303 {
1304 start = path + 2;
1305 *tmpstart++ = path[0];
1306 *tmpstart++ = ':';
1307 }
1308 /* UNC prefix */
1309 else if ((path[0] == '/' || path[0] == '\\') &&
1310 (path[1] == '/' || path[1] == '\\'))
1311 {
1312 start = path + 2;
52fcf7ee
GS		 1313 *tmpstart++ = path[0];
1314 *tmpstart++ = path[1];
8ac9c18d
GS		 1315 /* copy machine name */
1316 while (*start && *start != '/' && *start != '\\')
1317 *tmpstart++ = *start++;
1318 if (*start) {
52fcf7ee 1319 *tmpstart++ = *start;
8ac9c18d
GS		 1320 start++;
1321 /* copy share name */
1322 while (*start && *start != '/' && *start != '\\')
1323 *tmpstart++ = *start++;
1324 }
1325 }
1326 sep = *start++;
1327 if (sep == '/' || sep == '\\')
52fcf7ee 1328 *tmpstart++ = sep;
8ac9c18d
GS		 1329 *tmpstart = '\0';
1330 while (sep) {
1331 /* walk up to slash */
1332 while (*start && *start != '/' && *start != '\\')
1333 ++start;
1334
1335 /* discard doubled slashes */
1336 while (*start && (start[1] == '/' || start[1] == '\\'))
1337 ++start;
1338 sep = *start;
1339
1340 /* stop and find full name of component */
1341 *start = '\0';
1342 fhand = FindFirstFile(path,&fdata);
1343 if (fhand != INVALID_HANDLE_VALUE) {
1344 strcpy(tmpstart, fdata.cFileName);
1345 tmpstart += strlen(fdata.cFileName);
1346 if (sep)
52fcf7ee 1347 *tmpstart++ = sep;
8ac9c18d
GS		 1348 *tmpstart = '\0';
1349 *start++ = sep;
1350 FindClose(fhand);
1351 }
1352 else {
1353 /* failed a step, just return without side effects */
bf49b057 1354 /*PerlIO_printf(Perl_debug_log, "Failed to find %s\n", path);*/
8ac9c18d
GS		 1355 *start = sep;
1356 return Nullch;
1357 }
1358 }
1359 strcpy(path,tmpbuf);
1360 return path;
1361}
1362
0551aaa8
GS		 1363DllExport char *
1364win32_getenv(const char *name)
1365{
acfe0abc 1366 dTHX;
82867ecf 1367 WCHAR wBuffer[MAX_PATH+1];
0551aaa8 1368 DWORD needlen;
51371543 1369 SV *curitem = Nullsv;
58a50f62 1370
7fac1903 1371 if (USING_WIDE()) {
0cb96387 1372 A2WHELPER(name, wBuffer, sizeof(wBuffer));
51371543 1373 needlen = GetEnvironmentVariableW(wBuffer, NULL, 0);
7fac1903
GS		 1374 }
1375 else
51371543 1376 needlen = GetEnvironmentVariableA(name,NULL,0);
58a50f62 1377 if (needlen != 0) {
51371543 1378 curitem = sv_2mortal(newSVpvn("", 0));
7fac1903 1379 if (USING_WIDE()) {
51371543
GS		 1380 SV *acuritem;
1381 do {
1382 SvGROW(curitem, (needlen+1)*sizeof(WCHAR));
1383 needlen = GetEnvironmentVariableW(wBuffer,
1384 (WCHAR*)SvPVX(curitem),
1385 needlen);
1386 } while (needlen >= SvLEN(curitem)/sizeof(WCHAR));
c5be433b 1387 SvCUR_set(curitem, (needlen*sizeof(WCHAR))+1);
51371543
GS		 1388 acuritem = sv_2mortal(newSVsv(curitem));
1389 W2AHELPER((WCHAR*)SvPVX(acuritem), SvPVX(curitem), SvCUR(curitem));
7fac1903
GS		 1390 }
1391 else {
51371543
GS		 1392 do {
1393 SvGROW(curitem, needlen+1);
1394 needlen = GetEnvironmentVariableA(name,SvPVX(curitem),
1395 needlen);
1396 } while (needlen >= SvLEN(curitem));
1397 SvCUR_set(curitem, needlen);
58a50f62 1398 }
0551aaa8 1399 }
c934e9d4 1400 else {
7a5f8e82 1401 /* allow any environment variables that begin with 'PERL'
c934e9d4 1402 to be stored in the registry */
51371543 1403 if (strncmp(name, "PERL", 4) == 0)
c5be433b 1404 (void)get_regstr(name, &curitem);
c69f6586 1405 }
51371543
GS		 1406 if (curitem && SvCUR(curitem))
1407 return SvPVX(curitem);
58a50f62 1408
51371543 1409 return Nullch;
0551aaa8
GS		 1410}
1411
ac5c734f
GS		 1412DllExport int
1413win32_putenv(const char *name)
1414{
acfe0abc 1415 dTHX;
ac5c734f
GS		 1416 char* curitem;
1417 char* val;
7fac1903
GS		 1418 WCHAR* wCuritem;
1419 WCHAR* wVal;
1420 int length, relval = -1;
51371543 1421
73c4f7a1 1422 if (name) {
7fac1903
GS		 1423 if (USING_WIDE()) {
1424 length = strlen(name)+1;
1425 New(1309,wCuritem,length,WCHAR);
c5be433b 1426 A2WHELPER(name, wCuritem, length*sizeof(WCHAR));
7fac1903 1427 wVal = wcschr(wCuritem, '=');
7766f137 1428 if (wVal) {
7fac1903 1429 *wVal++ = '\0';
7766f137 1430 if (SetEnvironmentVariableW(wCuritem, *wVal ? wVal : NULL))
7fac1903
GS		 1431 relval = 0;
1432 }
1433 Safefree(wCuritem);
1434 }
1435 else {
1436 New(1309,curitem,strlen(name)+1,char);
1437 strcpy(curitem, name);
1438 val = strchr(curitem, '=');
7766f137 1439 if (val) {
7fac1903
GS		 1440 /* The sane way to deal with the environment.
1441 * Has these advantages over putenv() & co.:
1442 * * enables us to store a truly empty value in the
1443 * environment (like in UNIX).
1444 * * we don't have to deal with RTL globals, bugs and leaks.
1445 * * Much faster.
1446 * Why you may want to enable USE_WIN32_RTL_ENV:
1447 * * environ[] and RTL functions will not reflect changes,
1448 * which might be an issue if extensions want to access
1449 * the env. via RTL. This cuts both ways, since RTL will
1450 * not see changes made by extensions that call the Win32
1451 * functions directly, either.
1452 * GSAR 97-06-07
1453 */
1454 *val++ = '\0';
7766f137 1455 if (SetEnvironmentVariableA(curitem, *val ? val : NULL))
7fac1903
GS		 1456 relval = 0;
1457 }
1458 Safefree(curitem);
ac5c734f 1459 }
ac5c734f
GS		 1460 }
1461 return relval;
1462}
1463
d55594ae 1464static long
2d7a9237 1465filetime_to_clock(PFILETIME ft)
d55594ae 1466{
7766f137
GS		 1467 __int64 qw = ft->dwHighDateTime;
1468 qw <<= 32;
1469 qw |= ft->dwLowDateTime;
1470 qw /= 10000; /* File time ticks at 0.1uS, clock at 1mS */
1471 return (long) qw;
d55594ae
GS		 1472}
1473
f3986ebb
GS		 1474DllExport int
1475win32_times(struct tms *timebuf)
0a753a76 1476{
d55594ae
GS		 1477 FILETIME user;
1478 FILETIME kernel;
1479 FILETIME dummy;
3fadfdf1 1480 if (GetProcessTimes(GetCurrentProcess(), &dummy, &dummy,
d55594ae 1481 &kernel,&user)) {
2d7a9237
GS		 1482 timebuf->tms_utime = filetime_to_clock(&user);
1483 timebuf->tms_stime = filetime_to_clock(&kernel);
d55594ae
GS		 1484 timebuf->tms_cutime = 0;
1485 timebuf->tms_cstime = 0;
3fadfdf1
NIS		 1486
1487 } else {
d55594ae
GS		 1488 /* That failed - e.g. Win95 fallback to clock() */
1489 clock_t t = clock();
1490 timebuf->tms_utime = t;
1491 timebuf->tms_stime = 0;
1492 timebuf->tms_cutime = 0;
1493 timebuf->tms_cstime = 0;
1494 }
68dc0745 1495 return 0;
0a753a76 1496}
1497
9c51cf4c 1498/* fix utime() so it works on directories in NT */
ad0751ec
GS		 1499static BOOL
1500filetime_from_time(PFILETIME pFileTime, time_t Time)
1501{
9c51cf4c 1502 struct tm *pTM = localtime(&Time);
ad0751ec 1503 SYSTEMTIME SystemTime;
9c51cf4c 1504 FILETIME LocalTime;
ad0751ec
GS		 1505
1506 if (pTM == NULL)
1507 return FALSE;
1508
1509 SystemTime.wYear = pTM->tm_year + 1900;
1510 SystemTime.wMonth = pTM->tm_mon + 1;
1511 SystemTime.wDay = pTM->tm_mday;
1512 SystemTime.wHour = pTM->tm_hour;
1513 SystemTime.wMinute = pTM->tm_min;
1514 SystemTime.wSecond = pTM->tm_sec;
1515 SystemTime.wMilliseconds = 0;
1516
9c51cf4c
GS		 1517 return SystemTimeToFileTime(&SystemTime, &LocalTime) &&
1518 LocalFileTimeToFileTime(&LocalTime, pFileTime);
ad0751ec
GS		 1519}
1520
1521DllExport int
7766f137
GS		 1522win32_unlink(const char *filename)
1523{
acfe0abc 1524 dTHX;
7766f137
GS		 1525 int ret;
1526 DWORD attrs;
1527
1528 if (USING_WIDE()) {
82867ecf 1529 WCHAR wBuffer[MAX_PATH+1];
e9ff6d27 1530 WCHAR* pwBuffer;
7766f137
GS		 1531
1532 A2WHELPER(filename, wBuffer, sizeof(wBuffer));
e9ff6d27
GS		 1533 pwBuffer = PerlDir_mapW(wBuffer);
1534 attrs = GetFileAttributesW(pwBuffer);
c00206c8
GS		 1535 if (attrs == 0xFFFFFFFF)
1536 goto fail;
7766f137 1537 if (attrs & FILE_ATTRIBUTE_READONLY) {
e9ff6d27
GS		 1538 (void)SetFileAttributesW(pwBuffer, attrs & ~FILE_ATTRIBUTE_READONLY);
1539 ret = _wunlink(pwBuffer);
7766f137 1540 if (ret == -1)
e9ff6d27 1541 (void)SetFileAttributesW(pwBuffer, attrs);
7766f137
GS		 1542 }
1543 else
e9ff6d27 1544 ret = _wunlink(pwBuffer);
7766f137
GS		 1545 }
1546 else {
e9ff6d27
GS		 1547 filename = PerlDir_mapA(filename);
1548 attrs = GetFileAttributesA(filename);
c00206c8
GS		 1549 if (attrs == 0xFFFFFFFF)
1550 goto fail;
7766f137 1551 if (attrs & FILE_ATTRIBUTE_READONLY) {
e9ff6d27
GS		 1552 (void)SetFileAttributesA(filename, attrs & ~FILE_ATTRIBUTE_READONLY);
1553 ret = unlink(filename);
7766f137 1554 if (ret == -1)
e9ff6d27 1555 (void)SetFileAttributesA(filename, attrs);
7766f137
GS		 1556 }
1557 else
e9ff6d27 1558 ret = unlink(filename);
7766f137
GS		 1559 }
1560 return ret;
c00206c8
GS		 1561fail:
1562 errno = ENOENT;
1563 return -1;
7766f137
GS		 1564}
1565
1566DllExport int
3b405fc5 1567win32_utime(const char *filename, struct utimbuf *times)
ad0751ec 1568{
acfe0abc 1569 dTHX;
ad0751ec
GS		 1570 HANDLE handle;
1571 FILETIME ftCreate;
1572 FILETIME ftAccess;
1573 FILETIME ftWrite;
1574 struct utimbuf TimeBuffer;
82867ecf 1575 WCHAR wbuffer[MAX_PATH+1];
e9ff6d27 1576 WCHAR* pwbuffer;
ad0751ec 1577
7fac1903
GS		 1578 int rc;
1579 if (USING_WIDE()) {
0cb96387 1580 A2WHELPER(filename, wbuffer, sizeof(wbuffer));
e9ff6d27
GS		 1581 pwbuffer = PerlDir_mapW(wbuffer);
1582 rc = _wutime(pwbuffer, (struct _utimbuf*)times);
7fac1903
GS		 1583 }
1584 else {
e9ff6d27
GS		 1585 filename = PerlDir_mapA(filename);
1586 rc = utime(filename, times);
7fac1903 1587 }
ad0751ec
GS		 1588 /* EACCES: path specifies directory or readonly file */
1589 if (rc == 0 || errno != EACCES /* || !IsWinNT() */)
1590 return rc;
1591
1592 if (times == NULL) {
1593 times = &TimeBuffer;
1594 time(&times->actime);
1595 times->modtime = times->actime;
1596 }
1597
1598 /* This will (and should) still fail on readonly files */
7fac1903 1599 if (USING_WIDE()) {
e9ff6d27 1600 handle = CreateFileW(pwbuffer, GENERIC_READ | GENERIC_WRITE,
7fac1903
GS		 1601 FILE_SHARE_READ | FILE_SHARE_DELETE, NULL,
1602 OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL);
1603 }
1604 else {
e9ff6d27 1605 handle = CreateFileA(filename, GENERIC_READ | GENERIC_WRITE,
7fac1903
GS		 1606 FILE_SHARE_READ | FILE_SHARE_DELETE, NULL,
1607 OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL);
1608 }
ad0751ec
GS		 1609 if (handle == INVALID_HANDLE_VALUE)
1610 return rc;
1611
1612 if (GetFileTime(handle, &ftCreate, &ftAccess, &ftWrite) &&
1613 filetime_from_time(&ftAccess, times->actime) &&
1614 filetime_from_time(&ftWrite, times->modtime) &&
1615 SetFileTime(handle, &ftCreate, &ftAccess, &ftWrite))
1616 {
1617 rc = 0;
1618 }
1619
1620 CloseHandle(handle);
1621 return rc;
1622}
1623
2d7a9237 1624DllExport int
b2af26b1
GS		 1625win32_uname(struct utsname *name)
1626{
1627 struct hostent *hep;
1628 STRLEN nodemax = sizeof(name->nodename)-1;
1629 OSVERSIONINFO osver;
1630
1631 memset(&osver, 0, sizeof(OSVERSIONINFO));
1632 osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
1633 if (GetVersionEx(&osver)) {
1634 /* sysname */
1635 switch (osver.dwPlatformId) {
1636 case VER_PLATFORM_WIN32_WINDOWS:
1637 strcpy(name->sysname, "Windows");
1638 break;
1639 case VER_PLATFORM_WIN32_NT:
1640 strcpy(name->sysname, "Windows NT");
1641 break;
1642 case VER_PLATFORM_WIN32s:
1643 strcpy(name->sysname, "Win32s");
1644 break;
1645 default:
1646 strcpy(name->sysname, "Win32 Unknown");
1647 break;
1648 }
1649
cf6cacac
GS		 1650 /* release */
1651 sprintf(name->release, "%d.%d",
b2af26b1
GS		 1652 osver.dwMajorVersion, osver.dwMinorVersion);
1653
cf6cacac
GS		 1654 /* version */
1655 sprintf(name->version, "Build %d",
b2af26b1
GS		 1656 osver.dwPlatformId == VER_PLATFORM_WIN32_NT
1657 ? osver.dwBuildNumber : (osver.dwBuildNumber & 0xffff));
1658 if (osver.szCSDVersion[0]) {
cf6cacac 1659 char *buf = name->version + strlen(name->version);
b2af26b1
GS		 1660 sprintf(buf, " (%s)", osver.szCSDVersion);
1661 }
1662 }
1663 else {
1664 *name->sysname = '\0';
1665 *name->version = '\0';
1666 *name->release = '\0';
1667 }
1668
1669 /* nodename */
1670 hep = win32_gethostbyname("localhost");
1671 if (hep) {
1672 STRLEN len = strlen(hep->h_name);
1673 if (len <= nodemax) {
1674 strcpy(name->nodename, hep->h_name);
1675 }
1676 else {
1677 strncpy(name->nodename, hep->h_name, nodemax);
1678 name->nodename[nodemax] = '\0';
1679 }
1680 }
1681 else {
1682 DWORD sz = nodemax;
1683 if (!GetComputerName(name->nodename, &sz))
1684 *name->nodename = '\0';
1685 }
1686
1687 /* machine (architecture) */
1688 {
1689 SYSTEM_INFO info;
1690 char *arch;
1691 GetSystemInfo(&info);
a6c40364 1692
6f24f39d
JK		 1693#if (defined(__BORLANDC__)&&(__BORLANDC__<=0x520)) \
1694 || (defined(__MINGW32__) && !defined(_ANONYMOUS_UNION))
a6c40364
GS		 1695 switch (info.u.s.wProcessorArchitecture) {
1696#else
b2af26b1 1697 switch (info.wProcessorArchitecture) {
a6c40364 1698#endif
b2af26b1
GS		 1699 case PROCESSOR_ARCHITECTURE_INTEL:
1700 arch = "x86"; break;
1701 case PROCESSOR_ARCHITECTURE_MIPS:
1702 arch = "mips"; break;
1703 case PROCESSOR_ARCHITECTURE_ALPHA:
1704 arch = "alpha"; break;
1705 case PROCESSOR_ARCHITECTURE_PPC:
1706 arch = "ppc"; break;
1707 default:
1708 arch = "unknown"; break;
1709 }
1710 strcpy(name->machine, arch);
1711 }
1712 return 0;
1713}
1714
8fb3fcfb
NIS		 1715/* Timing related stuff */
1716
3fadfdf1
NIS		 1717int
1718do_raise(pTHX_ int sig)
1719{
1720 if (sig < SIG_SIZE) {
1721 Sighandler_t handler = w32_sighandler[sig];
1722 if (handler == SIG_IGN) {
1723 return 0;
1724 }
1725 else if (handler != SIG_DFL) {
1726 (*handler)(sig);
1727 return 0;
1728 }
1729 else {
1730 /* Choose correct default behaviour */
1731 switch (sig) {
1732#ifdef SIGCLD
1733 case SIGCLD:
1734#endif
1735#ifdef SIGCHLD
1736 case SIGCHLD:
1737#endif
1738 case 0:
1739 return 0;
1740 case SIGTERM:
1741 default:
1742 break;
1743 }
1744 }
1745 }
1746 /* Tell caller to exit thread/process as approriate */
1747 return 1;
1748}
1749
1750void
1751sig_terminate(pTHX_ int sig)
1752{
1753 Perl_warn(aTHX_ "Terminating on signal SIG%s(%d)\n",PL_sig_name[sig], sig);
1754 /* exit() seems to be safe, my_exit() or die() is a problem in ^C
1755 thread
1756 */
1757 exit(sig);
1758}
1759
8fb3fcfb
NIS		 1760DllExport int
1761win32_async_check(pTHX)
1762{
1763 MSG msg;
1764 int ours = 1;
7e5f34c0
NIS		 1765 /* Passing PeekMessage -1 as HWND (2nd arg) only get PostThreadMessage() messages
1766 * and ignores window messages - should co-exist better with windows apps e.g. Tk
3fadfdf1 1767 */
222c300a 1768 while (PeekMessage(&msg, (HWND)-1, 0, 0, PM_REMOVE|PM_NOYIELD)) {
3fadfdf1 1769 int sig;
8fb3fcfb
NIS		 1770 switch(msg.message) {
1771
7e5f34c0
NIS		 1772#if 0
1773 /* Perhaps some other messages could map to signals ? ... */
1774 case WM_CLOSE:
3fadfdf1 1775 case WM_QUIT:
7e5f34c0 1776 /* Treat WM_QUIT like SIGHUP? */
3fadfdf1
NIS		 1777 sig = SIGHUP;
1778 goto Raise;
7e5f34c0
NIS		 1779 break;
1780#endif
1781
c843839f 1782 /* We use WM_USER to fake kill() with other signals */
8fb3fcfb 1783 case WM_USER: {
3fadfdf1
NIS		 1784 sig = msg.wParam;
1785 Raise:
1786 if (do_raise(aTHX_ sig)) {
1787 sig_terminate(aTHX_ sig);
1788 }
8fb3fcfb
NIS		 1789 break;
1790 }
3fadfdf1 1791
8fb3fcfb
NIS		 1792 case WM_TIMER: {
1793 /* alarm() is a one-shot but SetTimer() repeats so kill it */
222c300a
NIS		 1794 if (w32_timerid) {
1795 KillTimer(NULL,w32_timerid);
3fadfdf1
NIS		 1796 w32_timerid=0;
1797 }
8fb3fcfb 1798 /* Now fake a call to signal handler */
3fadfdf1
NIS		 1799 if (do_raise(aTHX_ 14)) {
1800 sig_terminate(aTHX_ 14);
1801 }
8fb3fcfb
NIS		 1802 break;
1803 }
1804
1805 /* Otherwise do normal Win32 thing - in case it is useful */
1806 default:
1807 TranslateMessage(&msg);
1808 DispatchMessage(&msg);
1809 ours = 0;
1810 break;
1811 }
1812 }
05ec9bb3 1813 w32_poll_count = 0;
8fb3fcfb 1814
7e5f34c0 1815 /* Above or other stuff may have set a signal flag */
8fb3fcfb
NIS		 1816 if (PL_sig_pending) {
1817 despatch_signals();
1818 }
3fadfdf1 1819 return ours;
8fb3fcfb
NIS		 1820}
1821
1822DllExport DWORD
1823win32_msgwait(pTHX_ DWORD count, LPHANDLE handles, DWORD timeout, LPDWORD resultp)
1824{
1825 /* We may need several goes at this - so compute when we stop */
1826 DWORD ticks = 0;
1827 if (timeout != INFINITE) {
1828 ticks = GetTickCount();
1829 timeout += ticks;
1830 }
1831 while (1) {
1832 DWORD result = MsgWaitForMultipleObjects(count,handles,FALSE,timeout-ticks, QS_ALLEVENTS);
1833 if (resultp)
1834 *resultp = result;
1835 if (result == WAIT_TIMEOUT) {
3fadfdf1
NIS		 1836 /* Ran out of time - explicit return of zero to avoid -ve if we
1837 have scheduling issues
1838 */
8fb3fcfb
NIS		 1839 return 0;
1840 }
1841 if (timeout != INFINITE) {
1842 ticks = GetTickCount();
1843 }
1844 if (result == WAIT_OBJECT_0 + count) {
1845 /* Message has arrived - check it */
1846 if (win32_async_check(aTHX)) {
1847 /* was one of ours */
1848 break;
1849 }
1850 }
1851 else {
1852 /* Not timeout or message - one of handles is ready */
1853 break;
1854 }
1855 }
1856 /* compute time left to wait */
1857 ticks = timeout - ticks;
1858 /* If we are past the end say zero */
1859 return (ticks > 0) ? ticks : 0;
1860}
1861
932b7487
RC		 1862int
1863win32_internal_wait(int *status, DWORD timeout)
1864{
1865 /* XXX this wait emulation only knows about processes
1866 * spawned via win32_spawnvp(P_NOWAIT, ...).
1867 */
1868 dTHX;
1869 int i, retval;
1870 DWORD exitcode, waitcode;
1871
1872#ifdef USE_ITHREADS
1873 if (w32_num_pseudo_children) {
8fb3fcfb
NIS		 1874 win32_msgwait(aTHX_ w32_num_pseudo_children, w32_pseudo_child_handles,
1875 timeout, &waitcode);
932b7487
RC		 1876 /* Time out here if there are no other children to wait for. */
1877 if (waitcode == WAIT_TIMEOUT) {
1878 if (!w32_num_children) {
1879 return 0;
1880 }
1881 }
1882 else if (waitcode != WAIT_FAILED) {
1883 if (waitcode >= WAIT_ABANDONED_0
1884 && waitcode < WAIT_ABANDONED_0 + w32_num_pseudo_children)
1885 i = waitcode - WAIT_ABANDONED_0;
1886 else
1887 i = waitcode - WAIT_OBJECT_0;
1888 if (GetExitCodeThread(w32_pseudo_child_handles[i], &exitcode)) {
1889 *status = (int)((exitcode & 0xff) << 8);
1890 retval = (int)w32_pseudo_child_pids[i];
1891 remove_dead_pseudo_process(i);
1892 return -retval;
1893 }
1894 }
1895 }
1896#endif
1897
1898 if (!w32_num_children) {
1899 errno = ECHILD;
1900 return -1;
1901 }
1902
1903 /* if a child exists, wait for it to die */
8fb3fcfb 1904 win32_msgwait(aTHX_ w32_num_children, w32_child_handles, timeout, &waitcode);
932b7487
RC		 1905 if (waitcode == WAIT_TIMEOUT) {
1906 return 0;
1907 }
1908 if (waitcode != WAIT_FAILED) {
1909 if (waitcode >= WAIT_ABANDONED_0
1910 && waitcode < WAIT_ABANDONED_0 + w32_num_children)
1911 i = waitcode - WAIT_ABANDONED_0;
1912 else
1913 i = waitcode - WAIT_OBJECT_0;
1914 if (GetExitCodeProcess(w32_child_handles[i], &exitcode) ) {
1915 *status = (int)((exitcode & 0xff) << 8);
1916 retval = (int)w32_child_pids[i];
1917 remove_dead_process(i);
1918 return retval;
1919 }
1920 }
1921
1922FAILED:
1923 errno = GetLastError();
1924 return -1;
1925}
1926
b2af26b1 1927DllExport int
f55ee38a
GS		 1928win32_waitpid(int pid, int *status, int flags)
1929{
acfe0abc 1930 dTHX;
922b1888 1931 DWORD timeout = (flags & WNOHANG) ? 0 : INFINITE;
0aaad0ff 1932 int retval = -1;
c66b022d 1933 long child;
7766f137 1934 if (pid == -1) /* XXX threadid == 1 ? */
932b7487 1935 return win32_internal_wait(status, timeout);
7766f137
GS		 1936#ifdef USE_ITHREADS
1937 else if (pid < 0) {
c66b022d 1938 child = find_pseudo_pid(-pid);
7766f137
GS		 1939 if (child >= 0) {
1940 HANDLE hThread = w32_pseudo_child_handles[child];
8fb3fcfb
NIS		 1941 DWORD waitcode;
1942 win32_msgwait(aTHX_ 1, &hThread, timeout, &waitcode);
2f67576d
BC		 1943 if (waitcode == WAIT_TIMEOUT) {
1944 return 0;
1945 }
8fb3fcfb 1946 else if (waitcode == WAIT_OBJECT_0) {
7766f137
GS		 1947 if (GetExitCodeThread(hThread, &waitcode)) {
1948 *status = (int)((waitcode & 0xff) << 8);
1949 retval = (int)w32_pseudo_child_pids[child];
1950 remove_dead_pseudo_process(child);
68a29c53 1951 return -retval;
7766f137
GS		 1952 }
1953 }
1954 else
1955 errno = ECHILD;
1956 }
922b1888
GS		 1957 else if (IsWin95()) {
1958 pid = -pid;
1959 goto alien_process;
1960 }
7766f137
GS		 1961 }
1962#endif
f55ee38a 1963 else {
922b1888
GS		 1964 HANDLE hProcess;
1965 DWORD waitcode;
c66b022d 1966 child = find_pid(pid);
0aaad0ff 1967 if (child >= 0) {
922b1888 1968 hProcess = w32_child_handles[child];
8fb3fcfb 1969 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
a7867d0a
GS		 1970 if (waitcode == WAIT_TIMEOUT) {
1971 return 0;
1972 }
8fb3fcfb 1973 else if (waitcode == WAIT_OBJECT_0) {
922b1888
GS		 1974 if (GetExitCodeProcess(hProcess, &waitcode)) {
1975 *status = (int)((waitcode & 0xff) << 8);
1976 retval = (int)w32_child_pids[child];
1977 remove_dead_process(child);
1978 return retval;
1979 }
a7867d0a 1980 }
0aaad0ff
GS		 1981 else
1982 errno = ECHILD;
1983 }
1984 else {
922b1888
GS		 1985alien_process:
1986 hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE,
1987 (IsWin95() ? -pid : pid));
1988 if (hProcess) {
8fb3fcfb 1989 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
922b1888
GS		 1990 if (waitcode == WAIT_TIMEOUT) {
1991 return 0;
1992 }
8fb3fcfb 1993 else if (waitcode == WAIT_OBJECT_0) {
922b1888
GS		 1994 if (GetExitCodeProcess(hProcess, &waitcode)) {
1995 *status = (int)((waitcode & 0xff) << 8);
1996 CloseHandle(hProcess);
1997 return pid;
1998 }
1999 }
2000 CloseHandle(hProcess);
2001 }
2002 else
2003 errno = ECHILD;
0aaad0ff 2004 }
f55ee38a 2005 }
3fadfdf1 2006 return retval >= 0 ? pid : retval;
f55ee38a
GS		 2007}
2008
2009DllExport int
2d7a9237
GS		 2010win32_wait(int *status)
2011{
932b7487 2012 return win32_internal_wait(status, INFINITE);
2d7a9237 2013}
d55594ae 2014
8fb3fcfb
NIS		 2015DllExport unsigned int
2016win32_sleep(unsigned int t)
d55594ae 2017{
acfe0abc 2018 dTHX;
8fb3fcfb
NIS		 2019 /* Win32 times are in ms so *1000 in and /1000 out */
2020 return win32_msgwait(aTHX_ 0, NULL, t*1000, NULL)/1000;
d55594ae
GS		 2021}
2022
f3986ebb
GS		 2023DllExport unsigned int
2024win32_alarm(unsigned int sec)
0a753a76 2025{
3fadfdf1 2026 /*
d55594ae 2027 * the 'obvious' implentation is SetTimer() with a callback
3fadfdf1
NIS		 2028 * which does whatever receiving SIGALRM would do
2029 * we cannot use SIGALRM even via raise() as it is not
d55594ae 2030 * one of the supported codes in <signal.h>
3fadfdf1 2031 */
acfe0abc 2032 dTHX;
8fb3fcfb
NIS		 2033 if (sec) {
2034 w32_timerid = SetTimer(NULL,w32_timerid,sec*1000,NULL);
2035 }
2036 else {
2037 if (w32_timerid) {
2038 KillTimer(NULL,w32_timerid);
3fadfdf1 2039 w32_timerid=0;
8fb3fcfb 2040 }
3fadfdf1 2041 }
afe91769 2042 return 0;
0a753a76 2043}
2044
26618a56 2045#ifdef HAVE_DES_FCRYPT
2d77217b 2046extern char * des_fcrypt(const char *txt, const char *salt, char *cbuf);
ff95b63e 2047#endif
26618a56
GS		 2048
2049DllExport char *
2050win32_crypt(const char *txt, const char *salt)
2051{
acfe0abc 2052 dTHX;
ff95b63e 2053#ifdef HAVE_DES_FCRYPT
3352bfcb 2054 return des_fcrypt(txt, salt, w32_crypt_buffer);
ff95b63e 2055#else
25dbdbbc 2056 Perl_croak(aTHX_ "The crypt() function is unimplemented due to excessive paranoia.");
b8957cf1 2057 return Nullch;
ff95b63e 2058#endif
26618a56 2059}
26618a56 2060
9e5f57de 2061#ifdef USE_FIXED_OSFHANDLE
390b85e7
GS		 2062
2063#define FOPEN 0x01 /* file handle open */
b181b6fb 2064#define FNOINHERIT 0x10 /* file handle opened O_NOINHERIT */
390b85e7
GS		 2065#define FAPPEND 0x20 /* file handle opened O_APPEND */
2066#define FDEV 0x40 /* file handle refers to device */
2067#define FTEXT 0x80 /* file handle is in text mode */
2068
390b85e7
GS		 2069/***
2070*int my_open_osfhandle(long osfhandle, int flags) - open C Runtime file handle
2071*
2072*Purpose:
2073* This function allocates a free C Runtime file handle and associates
2074* it with the Win32 HANDLE specified by the first parameter. This is a
9e5f57de
GS		 2075* temperary fix for WIN95's brain damage GetFileType() error on socket
2076* we just bypass that call for socket
2077*
2078* This works with MSVC++ 4.0+ or GCC/Mingw32
390b85e7
GS		 2079*
2080*Entry:
2081* long osfhandle - Win32 HANDLE to associate with C Runtime file handle.
2082* int flags - flags to associate with C Runtime file handle.
2083*
2084*Exit:
2085* returns index of entry in fh, if successful
2086* return -1, if no free entry is found
2087*
2088*Exceptions:
2089*
2090*******************************************************************************/
2091
9e5f57de
GS		 2092/*
2093 * we fake up some parts of the CRT that aren't exported by MSVCRT.dll
2094 * this lets sockets work on Win9X with GCC and should fix the problems
2095 * with perl95.exe
2096 * -- BKS, 1-23-2000
2097*/
2098
9e5f57de
GS		 2099/* create an ioinfo entry, kill its handle, and steal the entry */
2100
b181b6fb
GS		 2101static int
2102_alloc_osfhnd(void)
9e5f57de
GS		 2103{
2104 HANDLE hF = CreateFile("NUL", 0, 0, NULL, OPEN_ALWAYS, 0, NULL);
dd8f4818 2105 int fh = _open_osfhandle((long)hF, 0);
9e5f57de
GS		 2106 CloseHandle(hF);
2107 if (fh == -1)
2108 return fh;
2109 EnterCriticalSection(&(_pioinfo(fh)->lock));
2110 return fh;
2111}
2112
390b85e7
GS		 2113static int
2114my_open_osfhandle(long osfhandle, int flags)
2115{
2116 int fh;
2117 char fileflags; /* _osfile flags */
2118
2119 /* copy relevant flags from second parameter */
2120 fileflags = FDEV;
2121
9404a519 2122 if (flags & O_APPEND)
390b85e7
GS		 2123 fileflags |= FAPPEND;
2124
9404a519 2125 if (flags & O_TEXT)
390b85e7
GS		 2126 fileflags |= FTEXT;
2127
b181b6fb
GS		 2128 if (flags & O_NOINHERIT)
2129 fileflags |= FNOINHERIT;
2130
390b85e7 2131 /* attempt to allocate a C Runtime file handle */
9404a519 2132 if ((fh = _alloc_osfhnd()) == -1) {
390b85e7
GS		 2133 errno = EMFILE; /* too many open files */
2134 _doserrno = 0L; /* not an OS error */
2135 return -1; /* return error to caller */
2136 }
2137
2138 /* the file is open. now, set the info in _osfhnd array */
2139 _set_osfhnd(fh, osfhandle);
2140
2141 fileflags |= FOPEN; /* mark as open */
2142
390b85e7 2143 _osfile(fh) = fileflags; /* set osfile entry */
dd8f4818 2144 LeaveCriticalSection(&_pioinfo(fh)->lock);
390b85e7
GS		 2145
2146 return fh; /* return handle */
2147}
2148
f3986ebb 2149#endif /* USE_FIXED_OSFHANDLE */
390b85e7
GS		 2150
2151/* simulate flock by locking a range on the file */
2152
2153#define LK_ERR(f,i) ((f) ? (i = 0) : (errno = GetLastError()))
2154#define LK_LEN 0xffff0000
2155
f3986ebb
GS		 2156DllExport int
2157win32_flock(int fd, int oper)
390b85e7
GS		 2158{
2159 OVERLAPPED o;
2160 int i = -1;
2161 HANDLE fh;
2162
f3986ebb 2163 if (!IsWinNT()) {
acfe0abc 2164 dTHX;
4f63d024 2165 Perl_croak_nocontext("flock() unimplemented on this platform");
f3986ebb
GS		 2166 return -1;
2167 }
390b85e7
GS		 2168 fh = (HANDLE)_get_osfhandle(fd);
2169 memset(&o, 0, sizeof(o));
2170
2171 switch(oper) {
2172 case LOCK_SH: /* shared lock */
2173 LK_ERR(LockFileEx(fh, 0, 0, LK_LEN, 0, &o),i);
2174 break;
2175 case LOCK_EX: /* exclusive lock */
2176 LK_ERR(LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK, 0, LK_LEN, 0, &o),i);
2177 break;
2178 case LOCK_SH|LOCK_NB: /* non-blocking shared lock */
2179 LK_ERR(LockFileEx(fh, LOCKFILE_FAIL_IMMEDIATELY, 0, LK_LEN, 0, &o),i);
2180 break;
2181 case LOCK_EX|LOCK_NB: /* non-blocking exclusive lock */
2182 LK_ERR(LockFileEx(fh,
2183 LOCKFILE_EXCLUSIVE_LOCK|LOCKFILE_FAIL_IMMEDIATELY,
2184 0, LK_LEN, 0, &o),i);
2185 break;
2186 case LOCK_UN: /* unlock lock */
2187 LK_ERR(UnlockFileEx(fh, 0, LK_LEN, 0, &o),i);
2188 break;
2189 default: /* unknown */
2190 errno = EINVAL;
2191 break;
2192 }
2193 return i;
2194}
2195
2196#undef LK_ERR
2197#undef LK_LEN
2198
68dc0745 2199/*
2200 * redirected io subsystem for all XS modules
2201 *
2202 */
0a753a76 2203
68dc0745 2204DllExport int *
2205win32_errno(void)
0a753a76 2206{
390b85e7 2207 return (&errno);
0a753a76 2208}
2209
dcb2879a
GS		 2210DllExport char ***
2211win32_environ(void)
2212{
390b85e7 2213 return (&(_environ));
dcb2879a
GS		 2214}
2215
68dc0745 2216/* the rest are the remapped stdio routines */
2217DllExport FILE *
2218win32_stderr(void)
0a753a76 2219{
390b85e7 2220 return (stderr);
0a753a76 2221}
2222
68dc0745 2223DllExport FILE *
2224win32_stdin(void)
0a753a76 2225{
390b85e7 2226 return (stdin);
0a753a76 2227}
2228
68dc0745 2229DllExport FILE *
2230win32_stdout()
0a753a76 2231{
390b85e7 2232 return (stdout);
0a753a76 2233}
2234
68dc0745 2235DllExport int
2236win32_ferror(FILE *fp)
0a753a76 2237{
390b85e7 2238 return (ferror(fp));
0a753a76 2239}
2240
2241
68dc0745 2242DllExport int
2243win32_feof(FILE *fp)
0a753a76 2244{
390b85e7 2245 return (feof(fp));
0a753a76 2246}
2247
68dc0745 2248/*
3fadfdf1 2249 * Since the errors returned by the socket error function
68dc0745 2250 * WSAGetLastError() are not known by the library routine strerror
2251 * we have to roll our own.
2252 */
0a753a76 2253
68dc0745 2254DllExport char *
3fadfdf1 2255win32_strerror(int e)
0a753a76 2256{
6f24f39d 2257#if !defined __BORLANDC__ && !defined __MINGW32__ /* compiler intolerance */
68dc0745 2258 extern int sys_nerr;
3e3baf6d 2259#endif
68dc0745 2260 DWORD source = 0;
0a753a76 2261
9404a519 2262 if (e < 0 || e > sys_nerr) {
acfe0abc 2263 dTHX;
9404a519 2264 if (e < 0)
68dc0745 2265 e = GetLastError();
0a753a76 2266
9404a519 2267 if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, &source, e, 0,
3352bfcb 2268 w32_strerror_buffer,
3fadfdf1 2269 sizeof(w32_strerror_buffer), NULL) == 0)
3352bfcb 2270 strcpy(w32_strerror_buffer, "Unknown Error");
0a753a76 2271
3352bfcb 2272 return w32_strerror_buffer;
68dc0745 2273 }
390b85e7 2274 return strerror(e);
0a753a76 2275}
2276
22fae026 2277DllExport void
c5be433b 2278win32_str_os_error(void *sv, DWORD dwErr)
22fae026
TM		 2279{
2280 DWORD dwLen;
2281 char *sMsg;
2282 dwLen = FormatMessageA(FORMAT_MESSAGE_ALLOCATE_BUFFER
2283 |FORMAT_MESSAGE_IGNORE_INSERTS
2284 |FORMAT_MESSAGE_FROM_SYSTEM, NULL,
2285 dwErr, 0, (char *)&sMsg, 1, NULL);
2ce77adf 2286 /* strip trailing whitespace and period */
22fae026 2287 if (0 < dwLen) {
2ce77adf
GS		 2288 do {
2289 --dwLen; /* dwLen doesn't include trailing null */
2290 } while (0 < dwLen && isSPACE(sMsg[dwLen]));
22fae026
TM		 2291 if ('.' != sMsg[dwLen])
2292 dwLen++;
2ce77adf 2293 sMsg[dwLen] = '\0';
22fae026
TM		 2294 }
2295 if (0 == dwLen) {
c69f6586 2296 sMsg = (char*)LocalAlloc(0, 64/**sizeof(TCHAR)*/);
db7c17d7
GS		 2297 if (sMsg)
2298 dwLen = sprintf(sMsg,
2299 "Unknown error #0x%lX (lookup 0x%lX)",
2300 dwErr, GetLastError());
2301 }
2302 if (sMsg) {
acfe0abc 2303 dTHX;
db7c17d7
GS		 2304 sv_setpvn((SV*)sv, sMsg, dwLen);
2305 LocalFree(sMsg);
22fae026 2306 }
22fae026
TM		 2307}
2308
68dc0745 2309DllExport int
2310win32_fprintf(FILE *fp, const char *format, ...)
0a753a76 2311{
68dc0745 2312 va_list marker;
2313 va_start(marker, format); /* Initialize variable arguments. */
0a753a76 2314
390b85e7 2315 return (vfprintf(fp, format, marker));
0a753a76 2316}
2317
68dc0745 2318DllExport int
2319win32_printf(const char *format, ...)
0a753a76 2320{
68dc0745 2321 va_list marker;
2322 va_start(marker, format); /* Initialize variable arguments. */
0a753a76 2323
390b85e7 2324 return (vprintf(format, marker));
0a753a76 2325}
2326
68dc0745 2327DllExport int
2328win32_vfprintf(FILE *fp, const char *format, va_list args)
0a753a76 2329{
390b85e7 2330 return (vfprintf(fp, format, args));
0a753a76 2331}
2332
96e4d5b1 2333DllExport int
2334win32_vprintf(const char *format, va_list args)
2335{
390b85e7 2336 return (vprintf(format, args));
96e4d5b1 2337}
2338
68dc0745 2339DllExport size_t
2340win32_fread(void *buf, size_t size, size_t count, FILE *fp)
0a753a76 2341{
390b85e7 2342 return fread(buf, size, count, fp);
0a753a76 2343}
2344
68dc0745 2345DllExport size_t
2346win32_fwrite(const void *buf, size_t size, size_t count, FILE *fp)
0a753a76 2347{
390b85e7 2348 return fwrite(buf, size, count, fp);
0a753a76 2349}
2350
7fac1903
GS		 2351#define MODE_SIZE 10
2352
68dc0745 2353DllExport FILE *
2354win32_fopen(const char *filename, const char *mode)
0a753a76 2355{
acfe0abc 2356 dTHX;
82867ecf 2357 WCHAR wMode[MODE_SIZE], wBuffer[MAX_PATH+1];
1c5905c2 2358 FILE *f;
3fadfdf1 2359
c5be433b
GS		 2360 if (!*filename)
2361 return NULL;
2362
68dc0745 2363 if (stricmp(filename, "/dev/null")==0)
7fac1903
GS		 2364 filename = "NUL";
2365
2366 if (USING_WIDE()) {
0cb96387
GS		 2367 A2WHELPER(mode, wMode, sizeof(wMode));
2368 A2WHELPER(filename, wBuffer, sizeof(wBuffer));
1c5905c2 2369 f = _wfopen(PerlDir_mapW(wBuffer), wMode);
7fac1903 2370 }
1c5905c2
GS		 2371 else
2372 f = fopen(PerlDir_mapA(filename), mode);
2373 /* avoid buffering headaches for child processes */
2374 if (f && *mode == 'a')
2375 win32_fseek(f, 0, SEEK_END);
2376 return f;
0a753a76 2377}
2378
f3986ebb
GS		 2379#ifndef USE_SOCKETS_AS_HANDLES
2380#undef fdopen
2381#define fdopen my_fdopen
2382#endif
2383
68dc0745 2384DllExport FILE *
7fac1903 2385win32_fdopen(int handle, const char *mode)
0a753a76 2386{
acfe0abc 2387 dTHX;
51371543 2388 WCHAR wMode[MODE_SIZE];
1c5905c2 2389 FILE *f;
7fac1903 2390 if (USING_WIDE()) {
0cb96387 2391 A2WHELPER(mode, wMode, sizeof(wMode));
1c5905c2 2392 f = _wfdopen(handle, wMode);
7fac1903 2393 }
1c5905c2
GS		 2394 else
2395 f = fdopen(handle, (char *) mode);
2396 /* avoid buffering headaches for child processes */
2397 if (f && *mode == 'a')
2398 win32_fseek(f, 0, SEEK_END);
2399 return f;
0a753a76 2400}
2401
68dc0745 2402DllExport FILE *
7fac1903 2403win32_freopen(const char *path, const char *mode, FILE *stream)
0a753a76 2404{
acfe0abc 2405 dTHX;
82867ecf 2406 WCHAR wMode[MODE_SIZE], wBuffer[MAX_PATH+1];
68dc0745 2407 if (stricmp(path, "/dev/null")==0)
7fac1903
GS		 2408 path = "NUL";
2409
2410 if (USING_WIDE()) {
0cb96387
GS		 2411 A2WHELPER(mode, wMode, sizeof(wMode));
2412 A2WHELPER(path, wBuffer, sizeof(wBuffer));
7766f137 2413 return _wfreopen(PerlDir_mapW(wBuffer), wMode, stream);
7fac1903 2414 }
7766f137 2415 return freopen(PerlDir_mapA(path), mode, stream);
0a753a76 2416}
2417
68dc0745 2418DllExport int
2419win32_fclose(FILE *pf)
0a753a76 2420{
f3986ebb 2421 return my_fclose(pf); /* defined in win32sck.c */
0a753a76 2422}
2423
68dc0745 2424DllExport int
2425win32_fputs(const char *s,FILE *pf)
0a753a76 2426{
390b85e7 2427 return fputs(s, pf);
0a753a76 2428}
2429
68dc0745 2430DllExport int
2431win32_fputc(int c,FILE *pf)
0a753a76 2432{
390b85e7 2433 return fputc(c,pf);
0a753a76 2434}
2435
68dc0745 2436DllExport int
2437win32_ungetc(int c,FILE *pf)
0a753a76 2438{
390b85e7 2439 return ungetc(c,pf);
0a753a76 2440}
2441
68dc0745 2442DllExport int
2443win32_getc(FILE *pf)
0a753a76 2444{
390b85e7 2445 return getc(pf);
0a753a76 2446}
2447
68dc0745 2448DllExport int
2449win32_fileno(FILE *pf)
0a753a76 2450{
390b85e7 2451 return fileno(pf);
0a753a76 2452}
2453
68dc0745 2454DllExport void
2455win32_clearerr(FILE *pf)
0a753a76 2456{
390b85e7 2457 clearerr(pf);
68dc0745 2458 return;
0a753a76 2459}
2460
68dc0745 2461DllExport int
2462win32_fflush(FILE *pf)
0a753a76 2463{
390b85e7 2464 return fflush(pf);
0a753a76 2465}
2466
68dc0745 2467DllExport long
2468win32_ftell(FILE *pf)
0a753a76 2469{
390b85e7 2470 return ftell(pf);
0a753a76 2471}
2472
68dc0745 2473DllExport int
2474win32_fseek(FILE *pf,long offset,int origin)
0a753a76 2475{
390b85e7 2476 return fseek(pf, offset, origin);
0a753a76 2477}
2478
68dc0745 2479DllExport int
2480win32_fgetpos(FILE *pf,fpos_t *p)
0a753a76 2481{
390b85e7 2482 return fgetpos(pf, p);
0a753a76 2483}
2484
68dc0745 2485DllExport int
2486win32_fsetpos(FILE *pf,const fpos_t *p)
0a753a76 2487{
390b85e7 2488 return fsetpos(pf, p);
0a753a76 2489}
2490
68dc0745 2491DllExport void
2492win32_rewind(FILE *pf)
0a753a76 2493{
390b85e7 2494 rewind(pf);
68dc0745 2495 return;
0a753a76 2496}
2497
68dc0745 2498DllExport FILE*
2499win32_tmpfile(void)
0a753a76 2500{
b3122bc4
JH		 2501 dTHX;
2502 char prefix[MAX_PATH+1];
2503 char filename[MAX_PATH+1];
2504 DWORD len = GetTempPath(MAX_PATH, prefix);
2505 if (len && len < MAX_PATH) {
2506 if (GetTempFileName(prefix, "plx", 0, filename)) {
2507 HANDLE fh = CreateFile(filename,
2508 DELETE | GENERIC_READ | GENERIC_WRITE,
2509 0,
2510 NULL,
2511 CREATE_ALWAYS,
2512 FILE_ATTRIBUTE_NORMAL
2513 | FILE_FLAG_DELETE_ON_CLOSE,
2514 NULL);
2515 if (fh != INVALID_HANDLE_VALUE) {
2516 int fd = win32_open_osfhandle((long)fh, 0);
2517 if (fd >= 0) {
2518 DEBUG_p(PerlIO_printf(Perl_debug_log,
2519 "Created tmpfile=%s\n",filename));
2520 return fdopen(fd, "w+b");
2521 }
2522 }
2523 }
2524 }
2525 return NULL;
0a753a76 2526}
2527
68dc0745 2528DllExport void
2529win32_abort(void)
0a753a76 2530{
390b85e7 2531 abort();
68dc0745 2532 return;
0a753a76 2533}
2534
68dc0745 2535DllExport int
22239a37 2536win32_fstat(int fd,struct stat *sbufptr)
0a753a76 2537{
2a07f407
VK		 2538#ifdef __BORLANDC__
2539 /* A file designated by filehandle is not shown as accessible
2540 * for write operations, probably because it is opened for reading.
2541 * --Vadim Konovalov
3fadfdf1 2542 */
2a07f407
VK		 2543 int rc = fstat(fd,sbufptr);
2544 BY_HANDLE_FILE_INFORMATION bhfi;
2545 if (GetFileInformationByHandle((HANDLE)_get_osfhandle(fd), &bhfi)) {
2546 sbufptr->st_mode &= 0xFE00;
2547 if (bhfi.dwFileAttributes & FILE_ATTRIBUTE_READONLY)
2548 sbufptr->st_mode |= (S_IREAD + (S_IREAD >> 3) + (S_IREAD >> 6));
2549 else
2550 sbufptr->st_mode |= ((S_IREAD|S_IWRITE) + ((S_IREAD|S_IWRITE) >> 3)
2551 + ((S_IREAD|S_IWRITE) >> 6));
2552 }
2553 return rc;
2554#else
ed59ec62 2555 return my_fstat(fd,sbufptr);
2a07f407 2556#endif
0a753a76 2557}
2558
68dc0745 2559DllExport int
2560win32_pipe(int *pfd, unsigned int size, int mode)
0a753a76 2561{
390b85e7 2562 return _pipe(pfd, size, mode);
0a753a76 2563}
2564
8c0134a8
NIS		 2565DllExport PerlIO*
2566win32_popenlist(const char *mode, IV narg, SV **args)
2567{
2568 dTHX;
2569 Perl_croak(aTHX_ "List form of pipe open not implemented");
2570 return NULL;
2571}
2572
50892819
GS		 2573/*
2574 * a popen() clone that respects PERL5SHELL
00b02797
JH		 2575 *
2576 * changed to return PerlIO* rather than FILE * by BKS, 11-11-2000
50892819
GS		 2577 */
2578
00b02797 2579DllExport PerlIO*
68dc0745 2580win32_popen(const char *command, const char *mode)
0a753a76 2581{
4b556e6c 2582#ifdef USE_RTL_POPEN
390b85e7 2583 return _popen(command, mode);
50892819
GS		 2584#else
2585 int p[2];
2586 int parent, child;
2587 int stdfd, oldfd;
2588 int ourmode;
2589 int childpid;
2590
2591 /* establish which ends read and write */
2592 if (strchr(mode,'w')) {
2593 stdfd = 0; /* stdin */
2594 parent = 1;
2595 child = 0;
2596 }
2597 else if (strchr(mode,'r')) {
2598 stdfd = 1; /* stdout */
2599 parent = 0;
2600 child = 1;
2601 }
2602 else
2603 return NULL;
2604
2605 /* set the correct mode */
2606 if (strchr(mode,'b'))
2607 ourmode = O_BINARY;
2608 else if (strchr(mode,'t'))
2609 ourmode = O_TEXT;
2610 else
2611 ourmode = _fmode & (O_TEXT | O_BINARY);
2612
2613 /* the child doesn't inherit handles */
2614 ourmode |= O_NOINHERIT;
2615
2616 if (win32_pipe( p, 512, ourmode) == -1)
2617 return NULL;
2618
2619 /* save current stdfd */
2620 if ((oldfd = win32_dup(stdfd)) == -1)
2621 goto cleanup;
2622
2623 /* make stdfd go to child end of pipe (implicitly closes stdfd) */
2624 /* stdfd will be inherited by the child */
2625 if (win32_dup2(p[child], stdfd) == -1)
2626 goto cleanup;
2627
2628 /* close the child end in parent */
2629 win32_close(p[child]);
2630
2631 /* start the child */
4f63d024 2632 {
acfe0abc 2633 dTHX;
c5be433b 2634 if ((childpid = do_spawn_nowait((char*)command)) == -1)
4f63d024 2635 goto cleanup;
50892819 2636
4f63d024
GS		 2637 /* revert stdfd to whatever it was before */
2638 if (win32_dup2(oldfd, stdfd) == -1)
2639 goto cleanup;
50892819 2640
4f63d024
GS		 2641 /* close saved handle */
2642 win32_close(oldfd);
50892819 2643
4755096e 2644 LOCK_FDPID_MUTEX;
4f63d024 2645 sv_setiv(*av_fetch(w32_fdpid, p[parent], TRUE), childpid);
4755096e 2646 UNLOCK_FDPID_MUTEX;
d91d68c1
RS		 2647
2648 /* set process id so that it can be returned by perl's open() */
2649 PL_forkprocess = childpid;
4f63d024 2650 }
50892819
GS		 2651
2652 /* we have an fd, return a file stream */
00b02797 2653 return (PerlIO_fdopen(p[parent], (char *)mode));
50892819
GS		 2654
2655cleanup:
2656 /* we don't need to check for errors here */
2657 win32_close(p[0]);
2658 win32_close(p[1]);
2659 if (oldfd != -1) {
2660 win32_dup2(oldfd, stdfd);
2661 win32_close(oldfd);
2662 }
2663 return (NULL);
2664
4b556e6c 2665#endif /* USE_RTL_POPEN */
0a753a76 2666}
2667
50892819
GS		 2668/*
2669 * pclose() clone
2670 */
2671
68dc0745 2672DllExport int
00b02797 2673win32_pclose(PerlIO *pf)
0a753a76 2674{
4b556e6c 2675#ifdef USE_RTL_POPEN
390b85e7 2676 return _pclose(pf);
50892819 2677#else
acfe0abc 2678 dTHX;
e17cb2a9
JD		 2679 int childpid, status;
2680 SV *sv;
2681
4755096e 2682 LOCK_FDPID_MUTEX;
00b02797 2683 sv = *av_fetch(w32_fdpid, PerlIO_fileno(pf), TRUE);
4755096e 2684
e17cb2a9
JD		 2685 if (SvIOK(sv))
2686 childpid = SvIVX(sv);
2687 else
2688 childpid = 0;
50892819
GS		 2689
2690 if (!childpid) {
2691 errno = EBADF;
2692 return -1;
2693 }
2694
00b02797
JH		 2695#ifdef USE_PERLIO
2696 PerlIO_close(pf);
2697#else
2698 fclose(pf);
2699#endif
e17cb2a9 2700 SvIVX(sv) = 0;
4755096e 2701 UNLOCK_FDPID_MUTEX;
e17cb2a9 2702
0aaad0ff
GS		 2703 if (win32_waitpid(childpid, &status, 0) == -1)
2704 return -1;
50892819 2705
0aaad0ff 2706 return status;
50892819 2707
4b556e6c 2708#endif /* USE_RTL_POPEN */
0a753a76 2709}
6b980173
JD		 2710
2711static BOOL WINAPI
2712Nt4CreateHardLinkW(
2713 LPCWSTR lpFileName,
2714 LPCWSTR lpExistingFileName,
2715 LPSECURITY_ATTRIBUTES lpSecurityAttributes)
2716{
2717 HANDLE handle;
2718 WCHAR wFullName[MAX_PATH+1];
2719 LPVOID lpContext = NULL;
2720 WIN32_STREAM_ID StreamId;
2721 DWORD dwSize = (char*)&StreamId.cStreamName - (char*)&StreamId;
2722 DWORD dwWritten;
2723 DWORD dwLen;
2724 BOOL bSuccess;
2725
2726 BOOL (__stdcall *pfnBackupWrite)(HANDLE, LPBYTE, DWORD, LPDWORD,
2727 BOOL, BOOL, LPVOID*) =
2728 (BOOL (__stdcall *)(HANDLE, LPBYTE, DWORD, LPDWORD,
2729 BOOL, BOOL, LPVOID*))
2730 GetProcAddress(GetModuleHandle("kernel32.dll"), "BackupWrite");
2731 if (pfnBackupWrite == NULL)
2732 return 0;
2733
2734 dwLen = GetFullPathNameW(lpFileName, MAX_PATH, wFullName, NULL);
2735 if (dwLen == 0)
2736 return 0;
2737 dwLen = (dwLen+1)*sizeof(WCHAR);
2738
2739 handle = CreateFileW(lpExistingFileName, FILE_WRITE_ATTRIBUTES,
2740 FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,
2741 NULL, OPEN_EXISTING, 0, NULL);
2742 if (handle == INVALID_HANDLE_VALUE)
2743 return 0;
2744
2745 StreamId.dwStreamId = BACKUP_LINK;
2746 StreamId.dwStreamAttributes = 0;
2747 StreamId.dwStreamNameSize = 0;
6f24f39d
JK		 2748#if defined(__BORLANDC__) \
2749 ||(defined(__MINGW32__) && !defined(_ANONYMOUS_UNION))
4ce4f76e
GS		 2750 StreamId.Size.u.HighPart = 0;
2751 StreamId.Size.u.LowPart = dwLen;
2752#else
6b980173
JD		 2753 StreamId.Size.HighPart = 0;
2754 StreamId.Size.LowPart = dwLen;
4ce4f76e 2755#endif
6b980173
JD		 2756
2757 bSuccess = pfnBackupWrite(handle, (LPBYTE)&StreamId, dwSize, &dwWritten,
2758 FALSE, FALSE, &lpContext);
2759 if (bSuccess) {
2760 bSuccess = pfnBackupWrite(handle, (LPBYTE)wFullName, dwLen, &dwWritten,
2761 FALSE, FALSE, &lpContext);
2762 pfnBackupWrite(handle, NULL, 0, &dwWritten, TRUE, FALSE, &lpContext);
2763 }
2764
2765 CloseHandle(handle);
2766 return bSuccess;
2767}
2768
2769DllExport int
2770win32_link(const char *oldname, const char *newname)
2771{
acfe0abc 2772 dTHX;
6b980173 2773 BOOL (__stdcall *pfnCreateHardLinkW)(LPCWSTR,LPCWSTR,LPSECURITY_ATTRIBUTES);
82867ecf
GS		 2774 WCHAR wOldName[MAX_PATH+1];
2775 WCHAR wNewName[MAX_PATH+1];
6b980173
JD		 2776
2777 if (IsWin95())
1be9d9c6 2778 Perl_croak(aTHX_ PL_no_func, "link");
6b980173
JD		 2779
2780 pfnCreateHardLinkW =
2781 (BOOL (__stdcall *)(LPCWSTR, LPCWSTR, LPSECURITY_ATTRIBUTES))
2782 GetProcAddress(GetModuleHandle("kernel32.dll"), "CreateHardLinkW");
2783 if (pfnCreateHardLinkW == NULL)
2784 pfnCreateHardLinkW = Nt4CreateHardLinkW;
2785
2786 if ((A2WHELPER(oldname, wOldName, sizeof(wOldName))) &&
2787 (A2WHELPER(newname, wNewName, sizeof(wNewName))) &&
7766f137
GS		 2788 (wcscpy(wOldName, PerlDir_mapW(wOldName)),
2789 pfnCreateHardLinkW(PerlDir_mapW(wNewName), wOldName, NULL)))
6b980173
JD		 2790 {
2791 return 0;
2792 }
2793 errno = (GetLastError() == ERROR_FILE_NOT_FOUND) ? ENOENT : EINVAL;
2794 return -1;
2795}
0a753a76 2796
68dc0745 2797DllExport int
8d9b2e3c 2798win32_rename(const char *oname, const char *newname)
e24c7c18 2799{
65cb15a1
GS		 2800 WCHAR wOldName[MAX_PATH+1];
2801 WCHAR wNewName[MAX_PATH+1];
2802 char szOldName[MAX_PATH+1];
2803 char szNewName[MAX_PATH+1];
7fac1903 2804 BOOL bResult;
acfe0abc 2805 dTHX;
65cb15a1 2806
80252599
GS		 2807 /* XXX despite what the documentation says about MoveFileEx(),
2808 * it doesn't work under Windows95!
2809 */
2810 if (IsWinNT()) {
65cb15a1 2811 DWORD dwFlags = MOVEFILE_COPY_ALLOWED;
7fac1903 2812 if (USING_WIDE()) {
0cb96387
GS		 2813 A2WHELPER(oname, wOldName, sizeof(wOldName));
2814 A2WHELPER(newname, wNewName, sizeof(wNewName));
65cb15a1
GS		 2815 if (wcsicmp(wNewName, wOldName))
2816 dwFlags |= MOVEFILE_REPLACE_EXISTING;
7766f137 2817 wcscpy(wOldName, PerlDir_mapW(wOldName));
65cb15a1 2818 bResult = MoveFileExW(wOldName,PerlDir_mapW(wNewName), dwFlags);
7fac1903
GS		 2819 }
2820 else {
65cb15a1
GS		 2821 if (stricmp(newname, oname))
2822 dwFlags |= MOVEFILE_REPLACE_EXISTING;
2823 strcpy(szOldName, PerlDir_mapA(oname));
2824 bResult = MoveFileExA(szOldName,PerlDir_mapA(newname), dwFlags);
7fac1903
GS		 2825 }
2826 if (!bResult) {
80252599
GS		 2827 DWORD err = GetLastError();
2828 switch (err) {
2829 case ERROR_BAD_NET_NAME:
2830 case ERROR_BAD_NETPATH:
2831 case ERROR_BAD_PATHNAME:
2832 case ERROR_FILE_NOT_FOUND:
2833 case ERROR_FILENAME_EXCED_RANGE:
2834 case ERROR_INVALID_DRIVE:
2835 case ERROR_NO_MORE_FILES:
2836 case ERROR_PATH_NOT_FOUND:
2837 errno = ENOENT;
2838 break;
2839 default:
2840 errno = EACCES;
2841 break;
2842 }
2843 return -1;
2844 }
2845 return 0;
e24c7c18 2846 }
80252599
GS		 2847 else {
2848 int retval = 0;
65cb15a1 2849 char szTmpName[MAX_PATH+1];
80252599
GS		 2850 char dname[MAX_PATH+1];
2851 char *endname = Nullch;
2852 STRLEN tmplen = 0;
2853 DWORD from_attr, to_attr;
2854
65cb15a1
GS		 2855 strcpy(szOldName, PerlDir_mapA(oname));
2856 strcpy(szNewName, PerlDir_mapA(newname));
2857
80252599 2858 /* if oname doesn't exist, do nothing */
65cb15a1 2859 from_attr = GetFileAttributes(szOldName);
80252599
GS		 2860 if (from_attr == 0xFFFFFFFF) {
2861 errno = ENOENT;
2862 return -1;
2863 }
2864
2865 /* if newname exists, rename it to a temporary name so that we
2866 * don't delete it in case oname happens to be the same file
2867 * (but perhaps accessed via a different path)
2868 */
65cb15a1 2869 to_attr = GetFileAttributes(szNewName);
80252599
GS		 2870 if (to_attr != 0xFFFFFFFF) {
2871 /* if newname is a directory, we fail
2872 * XXX could overcome this with yet more convoluted logic */
2873 if (to_attr & FILE_ATTRIBUTE_DIRECTORY) {
2874 errno = EACCES;
2875 return -1;
2876 }
65cb15a1
GS		 2877 tmplen = strlen(szNewName);
2878 strcpy(szTmpName,szNewName);
2879 endname = szTmpName+tmplen;
2880 for (; endname > szTmpName ; --endname) {
80252599
GS		 2881 if (*endname == '/' || *endname == '\\') {
2882 *endname = '\0';
2883 break;
2884 }
2885 }
65cb15a1
GS		 2886 if (endname > szTmpName)
2887 endname = strcpy(dname,szTmpName);
e24c7c18 2888 else
80252599
GS		 2889 endname = ".";
2890
2891 /* get a temporary filename in same directory
2892 * XXX is this really the best we can do? */
65cb15a1 2893 if (!GetTempFileName((LPCTSTR)endname, "plr", 0, szTmpName)) {
80252599
GS		 2894 errno = ENOENT;
2895 return -1;
2896 }
65cb15a1 2897 DeleteFile(szTmpName);
80252599 2898
65cb15a1 2899 retval = rename(szNewName, szTmpName);
80252599
GS		 2900 if (retval != 0) {
2901 errno = EACCES;
2902 return retval;
e24c7c18
GS		 2903 }
2904 }
80252599
GS		 2905
2906 /* rename oname to newname */
65cb15a1 2907 retval = rename(szOldName, szNewName);
80252599
GS		 2908
2909 /* if we created a temporary file before ... */
2910 if (endname != Nullch) {
2911 /* ...and rename succeeded, delete temporary file/directory */
2912 if (retval == 0)
65cb15a1 2913 DeleteFile(szTmpName);
80252599
GS		 2914 /* else restore it to what it was */
2915 else
65cb15a1 2916 (void)rename(szTmpName, szNewName);
80252599
GS		 2917 }
2918 return retval;
e24c7c18 2919 }
e24c7c18
GS		 2920}
2921
2922DllExport int
68dc0745 2923win32_setmode(int fd, int mode)
0a753a76 2924{
390b85e7 2925 return setmode(fd, mode);
0a753a76 2926}
2927
96e4d5b1 2928DllExport long
2929win32_lseek(int fd, long offset, int origin)
2930{
390b85e7 2931 return lseek(fd, offset, origin);
96e4d5b1 2932}
2933
2934DllExport long
2935win32_tell(int fd)
2936{
390b85e7 2937 return tell(fd);
96e4d5b1 2938}
2939
68dc0745 2940DllExport int
2941win32_open(const char *path, int flag, ...)
0a753a76 2942{
acfe0abc 2943 dTHX;
68dc0745 2944 va_list ap;
2945 int pmode;
82867ecf 2946 WCHAR wBuffer[MAX_PATH+1];
0a753a76 2947
2948 va_start(ap, flag);
2949 pmode = va_arg(ap, int);
2950 va_end(ap);
2951
68dc0745 2952 if (stricmp(path, "/dev/null")==0)
7fac1903
GS		 2953 path = "NUL";
2954
2955 if (USING_WIDE()) {
0cb96387 2956 A2WHELPER(path, wBuffer, sizeof(wBuffer));
7766f137 2957 return _wopen(PerlDir_mapW(wBuffer), flag, pmode);
7fac1903 2958 }
7766f137 2959 return open(PerlDir_mapA(path), flag, pmode);
0a753a76 2960}
2961
00b02797
JH		 2962/* close() that understands socket */
2963extern int my_close(int); /* in win32sck.c */
2964
68dc0745 2965DllExport int
2966win32_close(int fd)
0a753a76 2967{
00b02797 2968 return my_close(fd);
0a753a76 2969}
2970
68dc0745 2971DllExport int
96e4d5b1 2972win32_eof(int fd)
2973{
390b85e7 2974 return eof(fd);
96e4d5b1 2975}
2976
2977DllExport int
68dc0745 2978win32_dup(int fd)
0a753a76 2979{
390b85e7 2980 return dup(fd);
0a753a76 2981}
2982
68dc0745 2983DllExport int
2984win32_dup2(int fd1,int fd2)
0a753a76 2985{
390b85e7 2986 return dup2(fd1,fd2);
0a753a76 2987}
2988
f7aeb604
GS		 2989#ifdef PERL_MSVCRT_READFIX
2990
2991#define LF 10 /* line feed */
2992#define CR 13 /* carriage return */
2993#define CTRLZ 26 /* ctrl-z means eof for text */
2994#define FOPEN 0x01 /* file handle open */
2995#define FEOFLAG 0x02 /* end of file has been encountered */
2996#define FCRLF 0x04 /* CR-LF across read buffer (in text mode) */
2997#define FPIPE 0x08 /* file handle refers to a pipe */
2998#define FAPPEND 0x20 /* file handle opened O_APPEND */
2999#define FDEV 0x40 /* file handle refers to device */
3000#define FTEXT 0x80 /* file handle is in text mode */
3001#define MAX_DESCRIPTOR_COUNT (64*32) /* this is the maximun that MSVCRT can handle */
3002
b181b6fb
GS		 3003int __cdecl
3004_fixed_read(int fh, void *buf, unsigned cnt)
f7aeb604
GS		 3005{
3006 int bytes_read; /* number of bytes read */
3007 char *buffer; /* buffer to read to */
3008 int os_read; /* bytes read on OS call */
3009 char *p, *q; /* pointers into buffer */
3010 char peekchr; /* peek-ahead character */
3011 ULONG filepos; /* file position after seek */
3012 ULONG dosretval; /* o.s. return value */
3013
3014 /* validate handle */
3015 if (((unsigned)fh >= (unsigned)MAX_DESCRIPTOR_COUNT) ||
3016 !(_osfile(fh) & FOPEN))
3017 {
3018 /* out of range -- return error */
3019 errno = EBADF;
3020 _doserrno = 0; /* not o.s. error */
3021 return -1;
3022 }
3023
635bbe87
GS		 3024 /*
3025 * If lockinitflag is FALSE, assume fd is device
3026 * lockinitflag is set to TRUE by open.
3027 */
3028 if (_pioinfo(fh)->lockinitflag)
3029 EnterCriticalSection(&(_pioinfo(fh)->lock)); /* lock file */
f7aeb604
GS		 3030
3031 bytes_read = 0; /* nothing read yet */
3032 buffer = (char*)buf;
3033
3034 if (cnt == 0 || (_osfile(fh) & FEOFLAG)) {
3035 /* nothing to read or at EOF, so return 0 read */
3036 goto functionexit;
3037 }
3038
3039 if ((_osfile(fh) & (FPIPE|FDEV)) && _pipech(fh) != LF) {
3040 /* a pipe/device and pipe lookahead non-empty: read the lookahead
3041 * char */
3042 *buffer++ = _pipech(fh);
3043 ++bytes_read;
3044 --cnt;
3045 _pipech(fh) = LF; /* mark as empty */
3046 }
3047
3048 /* read the data */
3049
3050 if (!ReadFile((HANDLE)_osfhnd(fh), buffer, cnt, (LPDWORD)&os_read, NULL))
3051 {
3052 /* ReadFile has reported an error. recognize two special cases.
3053 *
3054 * 1. map ERROR_ACCESS_DENIED to EBADF
3055 *
3056 * 2. just return 0 if ERROR_BROKEN_PIPE has occurred. it
3057 * means the handle is a read-handle on a pipe for which
3058 * all write-handles have been closed and all data has been
3059 * read. */
3060
3061 if ((dosretval = GetLastError()) == ERROR_ACCESS_DENIED) {
3062 /* wrong read/write mode should return EBADF, not EACCES */
3063 errno = EBADF;
3064 _doserrno = dosretval;
3065 bytes_read = -1;
3066 goto functionexit;
3067 }
3068 else if (dosretval == ERROR_BROKEN_PIPE) {
3069 bytes_read = 0;
3070 goto functionexit;
3071 }
3072 else {
3073 bytes_read = -1;
3074 goto functionexit;
3075 }
3076 }
3077
3078 bytes_read += os_read; /* update bytes read */
3079
3080 if (_osfile(fh) & FTEXT) {
3081 /* now must translate CR-LFs to LFs in the buffer */
3082
3083 /* set CRLF flag to indicate LF at beginning of buffer */
3084 /* if ((os_read != 0) && (*(char *)buf == LF)) */
3085 /* _osfile(fh) |= FCRLF; */
3086 /* else */
3087 /* _osfile(fh) &= ~FCRLF; */
3088
3089 _osfile(fh) &= ~FCRLF;
3090
3091 /* convert chars in the buffer: p is src, q is dest */
3092 p = q = (char*)buf;
3093 while (p < (char *)buf + bytes_read) {
3094 if (*p == CTRLZ) {
3095 /* if fh is not a device, set ctrl-z flag */
3096 if (!(_osfile(fh) & FDEV))
3097 _osfile(fh) |= FEOFLAG;
3098 break; /* stop translating */
3099 }
3100 else if (*p != CR)
3101 *q++ = *p++;
3102 else {
3103 /* *p is CR, so must check next char for LF */
3104 if (p < (char *)buf + bytes_read - 1) {
3105 if (*(p+1) == LF) {
3106 p += 2;
3107 *q++ = LF; /* convert CR-LF to LF */
3108 }
3109 else
3110 *q++ = *p++; /* store char normally */
3111 }
3112 else {
3113 /* This is the hard part. We found a CR at end of
3114 buffer. We must peek ahead to see if next char
3115 is an LF. */
3116 ++p;
3117
3118 dosretval = 0;
3119 if (!ReadFile((HANDLE)_osfhnd(fh), &peekchr, 1,
3120 (LPDWORD)&os_read, NULL))
3121 dosretval = GetLastError();
3122
3123 if (dosretval != 0 || os_read == 0) {
3124 /* couldn't read ahead, store CR */
3125 *q++ = CR;
3126 }
3127 else {
3128 /* peekchr now has the extra character -- we now
3129 have several possibilities:
3130 1. disk file and char is not LF; just seek back
3131 and copy CR
3132 2. disk file and char is LF; store LF, don't seek back
3133 3. pipe/device and char is LF; store LF.
3134 4. pipe/device and char isn't LF, store CR and
3135 put char in pipe lookahead buffer. */
3136 if (_osfile(fh) & (FDEV|FPIPE)) {
3137 /* non-seekable device */
3138 if (peekchr == LF)
3139 *q++ = LF;
3140 else {
3141 *q++ = CR;
3142 _pipech(fh) = peekchr;
3143 }
3144 }
3145 else {
3146 /* disk file */
3147 if (peekchr == LF) {
3148 /* nothing read yet; must make some
3149 progress */
3150 *q++ = LF;
3151 /* turn on this flag for tell routine */
3152 _osfile(fh) |= FCRLF;
3153 }
3154 else {
3155 HANDLE osHandle; /* o.s. handle value */
3156 /* seek back */
3157 if ((osHandle = (HANDLE)_get_osfhandle(fh)) != (HANDLE)-1)
3158 {
3159 if ((filepos = SetFilePointer(osHandle, -1, NULL, FILE_CURRENT)) == -1)
3160 dosretval = GetLastError();
3161 }
3162 if (peekchr != LF)
3163 *q++ = CR;
3164 }
3165 }
3166 }
3167 }
3168 }
3169 }
3170
3171 /* we now change bytes_read to reflect the true number of chars
3172 in the buffer */
3173 bytes_read = q - (char *)buf;
3174 }
3175
3fadfdf1 3176functionexit:
635bbe87
GS		 3177 if (_pioinfo(fh)->lockinitflag)
3178 LeaveCriticalSection(&(_pioinfo(fh)->lock)); /* unlock file */
f7aeb604
GS		 3179
3180 return bytes_read;
3181}
3182
3183#endif /* PERL_MSVCRT_READFIX */
3184
68dc0745 3185DllExport int
3e3baf6d 3186win32_read(int fd, void *buf, unsigned int cnt)
0a753a76 3187{
f7aeb604
GS		 3188#ifdef PERL_MSVCRT_READFIX
3189 return _fixed_read(fd, buf, cnt);
3190#else
390b85e7 3191 return read(fd, buf, cnt);
f7aeb604 3192#endif
0a753a76 3193}
3194
68dc0745 3195DllExport int
3e3baf6d 3196win32_write(int fd, const void *buf, unsigned int cnt)
0a753a76 3197{
390b85e7 3198 return write(fd, buf, cnt);
0a753a76 3199}
3200
68dc0745 3201DllExport int
5aabfad6 3202win32_mkdir(const char *dir, int mode)
3203{
acfe0abc 3204 dTHX;
7766f137 3205 if (USING_WIDE()) {
82867ecf 3206 WCHAR wBuffer[MAX_PATH+1];
7766f137
GS		 3207 A2WHELPER(dir, wBuffer, sizeof(wBuffer));
3208 return _wmkdir(PerlDir_mapW(wBuffer));
3209 }
3210 return mkdir(PerlDir_mapA(dir)); /* just ignore mode */
5aabfad6 3211}
96e4d5b1 3212
5aabfad6 3213DllExport int
3214win32_rmdir(const char *dir)
3215{
acfe0abc 3216 dTHX;
7766f137 3217 if (USING_WIDE()) {
82867ecf 3218 WCHAR wBuffer[MAX_PATH+1];
7766f137
GS		 3219 A2WHELPER(dir, wBuffer, sizeof(wBuffer));
3220 return _wrmdir(PerlDir_mapW(wBuffer));
3221 }
3222 return rmdir(PerlDir_mapA(dir));
5aabfad6 3223}
96e4d5b1 3224
5aabfad6 3225DllExport int
3226win32_chdir(const char *dir)
3227{
4ae93879 3228 dTHX;
9ec3348a
JH		 3229 if (!dir) {
3230 errno = ENOENT;
3231 return -1;
3232 }
7766f137 3233 if (USING_WIDE()) {
82867ecf 3234 WCHAR wBuffer[MAX_PATH+1];
7766f137
GS		 3235 A2WHELPER(dir, wBuffer, sizeof(wBuffer));
3236 return _wchdir(wBuffer);
3237 }
390b85e7 3238 return chdir(dir);
5aabfad6 3239}
96e4d5b1 3240
7766f137
GS		 3241DllExport int
3242win32_access(const char *path, int mode)
3243{
acfe0abc 3244 dTHX;
7766f137 3245 if (USING_WIDE()) {
82867ecf 3246 WCHAR wBuffer[MAX_PATH+1];
7766f137
GS		 3247 A2WHELPER(path, wBuffer, sizeof(wBuffer));
3248 return _waccess(PerlDir_mapW(wBuffer), mode);
3249 }
3250 return access(PerlDir_mapA(path), mode);
3251}
3252
3253DllExport int
3254win32_chmod(const char *path, int mode)
3255{
acfe0abc 3256 dTHX;
7766f137 3257 if (USING_WIDE()) {
82867ecf 3258 WCHAR wBuffer[MAX_PATH+1];
7766f137
GS		 3259 A2WHELPER(path, wBuffer, sizeof(wBuffer));
3260 return _wchmod(PerlDir_mapW(wBuffer), mode);
3261 }
3262 return chmod(PerlDir_mapA(path), mode);
3263}
3264
3265
0aaad0ff 3266static char *
dd7038b3 3267create_command_line(char *cname, STRLEN clen, const char * const *args)
0aaad0ff 3268{
acfe0abc 3269 dTHX;
b309b8ae
JH		 3270 int index, argc;
3271 char *cmd, *ptr;
3272 const char *arg;
3273 STRLEN len = 0;
81bc1258 3274 bool bat_file = FALSE;
b309b8ae 3275 bool cmd_shell = FALSE;
7b11e424 3276 bool dumb_shell = FALSE;
b309b8ae 3277 bool extra_quotes = FALSE;
dd7038b3 3278 bool quote_next = FALSE;
81bc1258
JH		 3279
3280 if (!cname)
3281 cname = (char*)args[0];
b309b8ae
JH		 3282
3283 /* The NT cmd.exe shell has the following peculiarity that needs to be
3284 * worked around. It strips a leading and trailing dquote when any
3285 * of the following is true:
3286 * 1. the /S switch was used
3287 * 2. there are more than two dquotes
3288 * 3. there is a special character from this set: &<>()@^|
3289 * 4. no whitespace characters within the two dquotes
3290 * 5. string between two dquotes isn't an executable file
3291 * To work around this, we always add a leading and trailing dquote
3292 * to the string, if the first argument is either "cmd.exe" or "cmd",
3293 * and there were at least two or more arguments passed to cmd.exe
3294 * (not including switches).
dd7038b3
JH		 3295 * XXX the above rules (from "cmd /?") don't seem to be applied
3296 * always, making for the convolutions below :-(
b309b8ae 3297 */
81bc1258 3298 if (cname) {
dd7038b3
JH		 3299 if (!clen)
3300 clen = strlen(cname);
3301
81bc1258
JH		 3302 if (clen > 4
3303 && (stricmp(&cname[clen-4], ".bat") == 0
3304 || (IsWinNT() && stricmp(&cname[clen-4], ".cmd") == 0)))
3305 {
3306 bat_file = TRUE;
3307 len += 3;
3308 }
dd7038b3
JH		 3309 else {
3310 char *exe = strrchr(cname, '/');
3311 char *exe2 = strrchr(cname, '\\');
3312 if (exe2 > exe)
3313 exe = exe2;
3314 if (exe)
3315 ++exe;
3316 else
3317 exe = cname;
3318 if (stricmp(exe, "cmd.exe") == 0 || stricmp(exe, "cmd") == 0) {
3319 cmd_shell = TRUE;
3320 len += 3;
3321 }
7b11e424
JH		 3322 else if (stricmp(exe, "command.com") == 0
3323 || stricmp(exe, "command") == 0)
3324 {
3325 dumb_shell = TRUE;
3326 }
81bc1258 3327 }
b309b8ae 3328 }
0aaad0ff 3329
b309b8ae
JH		 3330 DEBUG_p(PerlIO_printf(Perl_debug_log, "Args "));
3331 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3332 STRLEN curlen = strlen(arg);
3333 if (!(arg[0] == '"' && arg[curlen-1] == '"'))
3334 len += 2; /* assume quoting needed (worst case) */
3335 len += curlen + 1;
3336 DEBUG_p(PerlIO_printf(Perl_debug_log, "[%s]",arg));
3337 }
3338 DEBUG_p(PerlIO_printf(Perl_debug_log, "\n"));
0aaad0ff 3339
b309b8ae 3340 argc = index;
0aaad0ff
GS		 3341 New(1310, cmd, len, char);
3342 ptr = cmd;
0aaad0ff 3343
81bc1258
JH		 3344 if (bat_file) {
3345 *ptr++ = '"';
3346 extra_quotes = TRUE;
3347 }
3348
0aaad0ff 3349 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
b309b8ae
JH		 3350 bool do_quote = 0;
3351 STRLEN curlen = strlen(arg);
3352
81bc1258
JH		 3353 /* we want to protect empty arguments and ones with spaces with
3354 * dquotes, but only if they aren't already there */
7b11e424
JH		 3355 if (!dumb_shell) {
3356 if (!curlen) {
3357 do_quote = 1;
3358 }
02ef22d5
JH		 3359 else if (quote_next) {
3360 /* see if it really is multiple arguments pretending to
3361 * be one and force a set of quotes around it */
3362 if (*find_next_space(arg))
3363 do_quote = 1;
3364 }
7b11e424
JH		 3365 else if (!(arg[0] == '"' && curlen > 1 && arg[curlen-1] == '"')) {
3366 STRLEN i = 0;
3367 while (i < curlen) {
3368 if (isSPACE(arg[i])) {
3369 do_quote = 1;
02ef22d5
JH		 3370 }
3371 else if (arg[i] == '"') {
3372 do_quote = 0;
7b11e424
JH		 3373 break;
3374 }
3375 i++;
b309b8ae 3376 }
b309b8ae 3377 }
dd7038b3 3378 }
b309b8ae
JH		 3379
3380 if (do_quote)
3381 *ptr++ = '"';
3382
18a945d4 3383 strcpy(ptr, arg);
b309b8ae
JH		 3384 ptr += curlen;
3385
3386 if (do_quote)
3387 *ptr++ = '"';
3388
3389 if (args[index+1])
3390 *ptr++ = ' ';
3391
81bc1258
JH		 3392 if (!extra_quotes
3393 && cmd_shell
dd7038b3 3394 && (stricmp(arg, "/x/c") == 0 || stricmp(arg, "/c") == 0))
b309b8ae 3395 {
dd7038b3
JH		 3396 /* is there a next argument? */
3397 if (args[index+1]) {
3398 /* are there two or more next arguments? */
3399 if (args[index+2]) {
3400 *ptr++ = '"';
3401 extra_quotes = TRUE;
3402 }
3403 else {
02ef22d5 3404 /* single argument, force quoting if it has spaces */
dd7038b3
JH		 3405 quote_next = TRUE;
3406 }
3407 }
b309b8ae 3408 }
0aaad0ff
GS		 3409 }
3410
b309b8ae
JH		 3411 if (extra_quotes)
3412 *ptr++ = '"';
3413
3414 *ptr = '\0';
3415
0aaad0ff
GS		 3416 return cmd;
3417}
3418
3419static char *
3420qualified_path(const char *cmd)
3421{
acfe0abc 3422 dTHX;
0aaad0ff
GS		 3423 char *pathstr;
3424 char *fullcmd, *curfullcmd;
3425 STRLEN cmdlen = 0;
3426 int has_slash = 0;
3427
3428 if (!cmd)
3429 return Nullch;
3430 fullcmd = (char*)cmd;
3431 while (*fullcmd) {
3432 if (*fullcmd == '/' || *fullcmd == '\\')
3433 has_slash++;
3434 fullcmd++;
3435 cmdlen++;
3436 }
3437
3438 /* look in PATH */
2fb9ab56 3439 pathstr = PerlEnv_getenv("PATH");
0aaad0ff
GS		 3440 New(0, fullcmd, MAX_PATH+1, char);
3441 curfullcmd = fullcmd;
3442
3443 while (1) {
3444 DWORD res;
3445
3446 /* start by appending the name to the current prefix */
3447 strcpy(curfullcmd, cmd);
3448 curfullcmd += cmdlen;
3449
3450 /* if it doesn't end with '.', or has no extension, try adding
3451 * a trailing .exe first */
3452 if (cmd[cmdlen-1] != '.'
3453 && (cmdlen < 4 || cmd[cmdlen-4] != '.'))
3454 {
3455 strcpy(curfullcmd, ".exe");
3456 res = GetFileAttributes(fullcmd);
3457 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3458 return fullcmd;
3459 *curfullcmd = '\0';
3460 }
3461
3462 /* that failed, try the bare name */
3463 res = GetFileAttributes(fullcmd);
3464 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3465 return fullcmd;
3466
3467 /* quit if no other path exists, or if cmd already has path */
3468 if (!pathstr || !*pathstr || has_slash)
3469 break;
3470
3471 /* skip leading semis */
3472 while (*pathstr == ';')
3473 pathstr++;
3474
3475 /* build a new prefix from scratch */
3476 curfullcmd = fullcmd;
3477 while (*pathstr && *pathstr != ';') {
3478 if (*pathstr == '"') { /* foo;"baz;etc";bar */
3479 pathstr++; /* skip initial '"' */
3480 while (*pathstr && *pathstr != '"') {
3481 if (curfullcmd-fullcmd < MAX_PATH-cmdlen-5)
3482 *curfullcmd++ = *pathstr;
3483 pathstr++;
3484 }
3485 if (*pathstr)
3486 pathstr++; /* skip trailing '"' */
3487 }
3488 else {
3489 if (curfullcmd-fullcmd < MAX_PATH-cmdlen-5)
3490 *curfullcmd++ = *pathstr;
3491 pathstr++;
3492 }
3493 }
3494 if (*pathstr)
3495 pathstr++; /* skip trailing semi */
3496 if (curfullcmd > fullcmd /* append a dir separator */
3497 && curfullcmd[-1] != '/' && curfullcmd[-1] != '\\')
3498 {
3499 *curfullcmd++ = '\\';
3500 }
3501 }
3502GIVE_UP:
3503 Safefree(fullcmd);
3504 return Nullch;
3505}
3506
3075ddba
GS		 3507/* The following are just place holders.
3508 * Some hosts may provide and environment that the OS is
3509 * not tracking, therefore, these host must provide that
3510 * environment and the current directory to CreateProcess
3511 */
3512
df3728a2
JH		 3513DllExport void*
3514win32_get_childenv(void)
3075ddba
GS		 3515{
3516 return NULL;
3517}
3518
df3728a2
JH		 3519DllExport void
3520win32_free_childenv(void* d)
3075ddba
GS		 3521{
3522}
3523
df3728a2
JH		 3524DllExport void
3525win32_clearenv(void)
3526{
3527 char *envv = GetEnvironmentStrings();
3528 char *cur = envv;
3529 STRLEN len;
3530 while (*cur) {
3531 char *end = strchr(cur,'=');
3532 if (end && end != cur) {
3533 *end = '\0';
3534 SetEnvironmentVariable(cur, NULL);
3535 *end = '=';
3536 cur = end + strlen(end+1)+2;
3537 }
3538 else if ((len = strlen(cur)))
3539 cur += len+1;
3540 }
3541 FreeEnvironmentStrings(envv);
3542}
3543
3544DllExport char*
3545win32_get_childdir(void)
3075ddba 3546{
acfe0abc 3547 dTHX;
7766f137
GS		 3548 char* ptr;
3549 char szfilename[(MAX_PATH+1)*2];
3550 if (USING_WIDE()) {
3551 WCHAR wfilename[MAX_PATH+1];
3552 GetCurrentDirectoryW(MAX_PATH+1, wfilename);
3553 W2AHELPER(wfilename, szfilename, sizeof(szfilename));
3554 }
3555 else {
3556 GetCurrentDirectoryA(MAX_PATH+1, szfilename);
3557 }
3558
3559 New(0, ptr, strlen(szfilename)+1, char);
3560 strcpy(ptr, szfilename);
3561 return ptr;
3075ddba
GS		 3562}
3563
df3728a2
JH		 3564DllExport void
3565win32_free_childdir(char* d)
3075ddba 3566{
acfe0abc 3567 dTHX;
7766f137 3568 Safefree(d);
3075ddba
GS		 3569}
3570
3571
0aaad0ff
GS		 3572/* XXX this needs to be made more compatible with the spawnvp()
3573 * provided by the various RTLs. In particular, searching for
3574 * *.{com,bat,cmd} files (as done by the RTLs) is unimplemented.
3575 * This doesn't significantly affect perl itself, because we
3576 * always invoke things using PERL5SHELL if a direct attempt to
3577 * spawn the executable fails.
3fadfdf1 3578 *
0aaad0ff
GS		 3579 * XXX splitting and rejoining the commandline between do_aspawn()
3580 * and win32_spawnvp() could also be avoided.
3581 */
3582
5aabfad6 3583DllExport int
3e3baf6d 3584win32_spawnvp(int mode, const char *cmdname, const char *const *argv)
0a753a76 3585{
0aaad0ff
GS		 3586#ifdef USE_RTL_SPAWNVP
3587 return spawnvp(mode, cmdname, (char * const *)argv);
3588#else
acfe0abc 3589 dTHX;
2b260de0 3590 int ret;
3075ddba
GS		 3591 void* env;
3592 char* dir;
635bbe87 3593 child_IO_table tbl;
0aaad0ff
GS		 3594 STARTUPINFO StartupInfo;
3595 PROCESS_INFORMATION ProcessInformation;
3596 DWORD create = 0;
dd7038b3 3597 char *cmd;
0aaad0ff 3598 char *fullcmd = Nullch;
dd7038b3
JH		 3599 char *cname = (char *)cmdname;
3600 STRLEN clen = 0;
3601
3602 if (cname) {
3603 clen = strlen(cname);
3604 /* if command name contains dquotes, must remove them */
3605 if (strchr(cname, '"')) {
3606 cmd = cname;
3607 New(0,cname,clen+1,char);
3608 clen = 0;
3609 while (*cmd) {
3610 if (*cmd != '"') {
3611 cname[clen] = *cmd;
3612 ++clen;
3613 }
3614 ++cmd;
3615 }
3616 cname[clen] = '\0';
3617 }
3618 }
3619
3620 cmd = create_command_line(cname, clen, argv);
0aaad0ff 3621
3075ddba
GS		 3622 env = PerlEnv_get_childenv();
3623 dir = PerlEnv_get_childdir();
3624
0aaad0ff
GS		 3625 switch(mode) {
3626 case P_NOWAIT: /* asynch + remember result */
3627 if (w32_num_children >= MAXIMUM_WAIT_OBJECTS) {
3628 errno = EAGAIN;
3629 ret = -1;
3630 goto RETVAL;
3631 }
3fadfdf1 3632 /* Create a new process group so we can use GenerateConsoleCtrlEvent()
7e5f34c0
NIS		 3633 * in win32_kill()
3634 */
3fadfdf1 3635 create |= CREATE_NEW_PROCESS_GROUP;
0aaad0ff 3636 /* FALL THROUGH */
7e5f34c0 3637
0aaad0ff
GS		 3638 case P_WAIT: /* synchronous execution */
3639 break;
3640 default: /* invalid mode */
3641 errno = EINVAL;
3642 ret = -1;
3643 goto RETVAL;
3644 }
3645 memset(&StartupInfo,0,sizeof(StartupInfo));
3646 StartupInfo.cb = sizeof(StartupInfo);
f83751a7 3647 memset(&tbl,0,sizeof(tbl));
635bbe87 3648 PerlEnv_get_child_IO(&tbl);
f83751a7 3649 StartupInfo.dwFlags = tbl.dwFlags;
3fadfdf1
NIS		 3650 StartupInfo.dwX = tbl.dwX;
3651 StartupInfo.dwY = tbl.dwY;
3652 StartupInfo.dwXSize = tbl.dwXSize;
3653 StartupInfo.dwYSize = tbl.dwYSize;
3654 StartupInfo.dwXCountChars = tbl.dwXCountChars;
3655 StartupInfo.dwYCountChars = tbl.dwYCountChars;
3656 StartupInfo.dwFillAttribute = tbl.dwFillAttribute;
3657 StartupInfo.wShowWindow = tbl.wShowWindow;
f83751a7
GS		 3658 StartupInfo.hStdInput = tbl.childStdIn;
3659 StartupInfo.hStdOutput = tbl.childStdOut;
3660 StartupInfo.hStdError = tbl.childStdErr;
3ffaa937
GS		 3661 if (StartupInfo.hStdInput != INVALID_HANDLE_VALUE &&
3662 StartupInfo.hStdOutput != INVALID_HANDLE_VALUE &&
3663 StartupInfo.hStdError != INVALID_HANDLE_VALUE)
3664 {
3665 StartupInfo.dwFlags |= STARTF_USESTDHANDLES;
3666 }
3667 else {
3668 create |= CREATE_NEW_CONSOLE;
3669 }
3670
b309b8ae 3671 DEBUG_p(PerlIO_printf(Perl_debug_log, "Spawning [%s] with [%s]\n",
dd7038b3 3672 cname,cmd));
0aaad0ff 3673RETRY:
dd7038b3 3674 if (!CreateProcess(cname, /* search PATH to find executable */
0aaad0ff
GS		 3675 cmd, /* executable, and its arguments */
3676 NULL, /* process attributes */
3677 NULL, /* thread attributes */
3678 TRUE, /* inherit handles */
3679 create, /* creation flags */
3075ddba
GS		 3680 (LPVOID)env, /* inherit environment */
3681 dir, /* inherit cwd */
0aaad0ff
GS		 3682 &StartupInfo,
3683 &ProcessInformation))
3684 {
3685 /* initial NULL argument to CreateProcess() does a PATH
3686 * search, but it always first looks in the directory
3687 * where the current process was started, which behavior
3688 * is undesirable for backward compatibility. So we
3689 * jump through our own hoops by picking out the path
3690 * we really want it to use. */
3691 if (!fullcmd) {
dd7038b3 3692 fullcmd = qualified_path(cname);
0aaad0ff 3693 if (fullcmd) {
dd7038b3
JH		 3694 if (cname != cmdname)
3695 Safefree(cname);
3696 cname = fullcmd;
b309b8ae
JH		 3697 DEBUG_p(PerlIO_printf(Perl_debug_log,
3698 "Retrying [%s] with same args\n",
dd7038b3 3699 cname));
0aaad0ff
GS		 3700 goto RETRY;
3701 }
3702 }
3703 errno = ENOENT;
3704 ret = -1;
3705 goto RETVAL;
3706 }
2d7a9237 3707
0aaad0ff
GS		 3708 if (mode == P_NOWAIT) {
3709 /* asynchronous spawn -- store handle, return PID */
2b260de0 3710 ret = (int)ProcessInformation.dwProcessId;
922b1888
GS		 3711 if (IsWin95() && ret < 0)
3712 ret = -ret;
3713
3714 w32_child_handles[w32_num_children] = ProcessInformation.hProcess;
3715 w32_child_pids[w32_num_children] = (DWORD)ret;
0aaad0ff
GS		 3716 ++w32_num_children;
3717 }
3718 else {
2b260de0 3719 DWORD status;
8fb3fcfb 3720 win32_msgwait(aTHX_ 1, &ProcessInformation.hProcess, INFINITE, NULL);
7e5f34c0
NIS		 3721 /* FIXME: if msgwait returned due to message perhaps forward the
3722 "signal" to the process
3723 */
2b260de0
GS		 3724 GetExitCodeProcess(ProcessInformation.hProcess, &status);
3725 ret = (int)status;
0aaad0ff
GS		 3726 CloseHandle(ProcessInformation.hProcess);
3727 }
e17cb2a9 3728
0aaad0ff 3729 CloseHandle(ProcessInformation.hThread);
3075ddba 3730
0aaad0ff 3731RETVAL:
3075ddba
GS		 3732 PerlEnv_free_childenv(env);
3733 PerlEnv_free_childdir(dir);
0aaad0ff 3734 Safefree(cmd);
dd7038b3
JH		 3735 if (cname != cmdname)
3736 Safefree(cname);
2b260de0 3737 return ret;
2d7a9237 3738#endif
0a753a76 3739}
3740
6890e559 3741DllExport int
eb62e965
JD		 3742win32_execv(const char *cmdname, const char *const *argv)
3743{
7766f137 3744#ifdef USE_ITHREADS
acfe0abc 3745 dTHX;
7766f137
GS		 3746 /* if this is a pseudo-forked child, we just want to spawn
3747 * the new program, and return */
3748 if (w32_pseudo_id)
3749 return spawnv(P_WAIT, cmdname, (char *const *)argv);
3750#endif
eb62e965
JD		 3751 return execv(cmdname, (char *const *)argv);
3752}
3753
3754DllExport int
6890e559
GS		 3755win32_execvp(const char *cmdname, const char *const *argv)
3756{
7766f137 3757#ifdef USE_ITHREADS
acfe0abc 3758 dTHX;
7766f137
GS		 3759 /* if this is a pseudo-forked child, we just want to spawn
3760 * the new program, and return */
190e4ad0 3761 if (w32_pseudo_id) {
ba6ce41c
GS		 3762 int status = win32_spawnvp(P_WAIT, cmdname, (char *const *)argv);
3763 if (status != -1) {
3764 my_exit(status);
3765 return 0;
3766 }
3767 else
3768 return status;
190e4ad0 3769 }
7766f137 3770#endif
390b85e7 3771 return execvp(cmdname, (char *const *)argv);
6890e559
GS		 3772}
3773
84902520
TB		 3774DllExport void
3775win32_perror(const char *str)
3776{
390b85e7 3777 perror(str);
84902520
TB		 3778}
3779
3780DllExport void
3781win32_setbuf(FILE *pf, char *buf)
3782{
390b85e7 3783 setbuf(pf, buf);
84902520
TB		 3784}
3785
3786DllExport int
3787win32_setvbuf(FILE *pf, char *buf, int type, size_t size)
3788{
390b85e7 3789 return setvbuf(pf, buf, type, size);
84902520
TB		 3790}
3791
3792DllExport int
3793win32_flushall(void)
3794{
390b85e7 3795 return flushall();
84902520
TB		 3796}
3797
3798DllExport int
3799win32_fcloseall(void)
3800{
390b85e7 3801 return fcloseall();
84902520
TB		 3802}
3803
3804DllExport char*
3805win32_fgets(char *s, int n, FILE *pf)
3806{
390b85e7 3807 return fgets(s, n, pf);
84902520
TB		 3808}
3809
3810DllExport char*
3811win32_gets(char *s)
3812{
390b85e7 3813 return gets(s);
84902520
TB		 3814}
3815
3816DllExport int
3817win32_fgetc(FILE *pf)
3818{
390b85e7 3819 return fgetc(pf);
84902520
TB		 3820}
3821
3822DllExport int
3823win32_putc(int c, FILE *pf)
3824{
390b85e7 3825 return putc(c,pf);
84902520
TB		 3826}
3827
3828DllExport int
3829win32_puts(const char *s)
3830{
390b85e7 3831 return puts(s);
84902520
TB		 3832}
3833
3834DllExport int
3835win32_getchar(void)
3836{
390b85e7 3837 return getchar();
84902520
TB		 3838}
3839
3840DllExport int
3841win32_putchar(int c)
3842{
390b85e7 3843 return putchar(c);
84902520
TB		 3844}
3845
bbc8f9de
NIS		 3846#ifdef MYMALLOC
3847
3848#ifndef USE_PERL_SBRK
3849
df3728a2
JH		 3850static char *committed = NULL; /* XXX threadead */
3851static char *base = NULL; /* XXX threadead */
3852static char *reserved = NULL; /* XXX threadead */
3853static char *brk = NULL; /* XXX threadead */
3854static DWORD pagesize = 0; /* XXX threadead */
3855static DWORD allocsize = 0; /* XXX threadead */
bbc8f9de
NIS		 3856
3857void *
3858sbrk(int need)
3859{
3860 void *result;
3861 if (!pagesize)
3862 {SYSTEM_INFO info;
3863 GetSystemInfo(&info);
3864 /* Pretend page size is larger so we don't perpetually
3865 * call the OS to commit just one page ...
3866 */
3867 pagesize = info.dwPageSize << 3;
3868 allocsize = info.dwAllocationGranularity;
3869 }
3870 /* This scheme fails eventually if request for contiguous
3fadfdf1 3871 * block is denied so reserve big blocks - this is only
bbc8f9de
NIS		 3872 * address space not memory ...
3873 */
3874 if (brk+need >= reserved)
3875 {
3876 DWORD size = 64*1024*1024;
3877 char *addr;
3878 if (committed && reserved && committed < reserved)
3879 {
3880 /* Commit last of previous chunk cannot span allocations */
161b471a 3881 addr = (char *) VirtualAlloc(committed,reserved-committed,MEM_COMMIT,PAGE_READWRITE);
bbc8f9de
NIS		 3882 if (addr)
3883 committed = reserved;
3884 }
3fadfdf1 3885 /* Reserve some (more) space
bbc8f9de
NIS		 3886 * Note this is a little sneaky, 1st call passes NULL as reserved
3887 * so lets system choose where we start, subsequent calls pass
3888 * the old end address so ask for a contiguous block
3889 */
161b471a 3890 addr = (char *) VirtualAlloc(reserved,size,MEM_RESERVE,PAGE_NOACCESS);
bbc8f9de
NIS		 3891 if (addr)
3892 {
3893 reserved = addr+size;
3894 if (!base)
3895 base = addr;
3896 if (!committed)
3897 committed = base;
3898 if (!brk)
3899 brk = committed;
3900 }
3901 else
3902 {
3903 return (void *) -1;
3904 }
3905 }
3906 result = brk;
3907 brk += need;
3908 if (brk > committed)
3909 {
3910 DWORD size = ((brk-committed + pagesize -1)/pagesize) * pagesize;
161b471a 3911 char *addr = (char *) VirtualAlloc(committed,size,MEM_COMMIT,PAGE_READWRITE);
bbc8f9de
NIS		 3912 if (addr)
3913 {
3914 committed += size;
3915 }
3916 else
3917 return (void *) -1;
3918 }
3919 return result;
3920}
3921
3922#endif
3923#endif
3924
84902520
TB		 3925DllExport void*
3926win32_malloc(size_t size)
3927{
390b85e7 3928 return malloc(size);
84902520
TB		 3929}
3930
3931DllExport void*
3932win32_calloc(size_t numitems, size_t size)
3933{
390b85e7 3934 return calloc(numitems,size);
84902520
TB		 3935}
3936
3937DllExport void*
3938win32_realloc(void *block, size_t size)
3939{
390b85e7 3940 return realloc(block,size);
84902520
TB		 3941}
3942
3943DllExport void
3944win32_free(void *block)
3945{
390b85e7 3946 free(block);
84902520
TB		 3947}
3948
bbc8f9de 3949
68dc0745 3950int
65e48ea9 3951win32_open_osfhandle(long handle, int flags)
0a753a76 3952{
9e5f57de
GS		 3953#ifdef USE_FIXED_OSFHANDLE
3954 if (IsWin95())
3955 return my_open_osfhandle(handle, flags);
3956#endif
390b85e7 3957 return _open_osfhandle(handle, flags);
0a753a76 3958}
3959
68dc0745 3960long
65e48ea9 3961win32_get_osfhandle(int fd)
0a753a76 3962{
390b85e7 3963 return _get_osfhandle(fd);
0a753a76 3964}
7bac28a0 3965
0cb96387 3966DllExport void*
c5be433b 3967win32_dynaload(const char* filename)
0cb96387 3968{
acfe0abc 3969 dTHX;
51371543 3970 HMODULE hModule;
32f99636
GS		 3971 char buf[MAX_PATH+1];
3972 char *first;
3973
3974 /* LoadLibrary() doesn't recognize forward slashes correctly,
3975 * so turn 'em back. */
3976 first = strchr(filename, '/');
3977 if (first) {
3978 STRLEN len = strlen(filename);
3979 if (len <= MAX_PATH) {
3980 strcpy(buf, filename);
3981 filename = &buf[first - filename];
3982 while (*filename) {
3983 if (*filename == '/')
3984 *(char*)filename = '\\';
3985 ++filename;
3986 }
3987 filename = buf;
3988 }
3989 }
0cb96387 3990 if (USING_WIDE()) {
82867ecf 3991 WCHAR wfilename[MAX_PATH+1];
0cb96387 3992 A2WHELPER(filename, wfilename, sizeof(wfilename));
7766f137 3993 hModule = LoadLibraryExW(PerlDir_mapW(wfilename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
0cb96387
GS		 3994 }
3995 else {
7766f137 3996 hModule = LoadLibraryExA(PerlDir_mapA(filename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
0cb96387
GS		 3997 }
3998 return hModule;
3999}
4000
7bac28a0 4001/*
4002 * Extras.
4003 */
4004
ad2e33dc
GS		 4005static
4006XS(w32_GetCwd)
4007{
4008 dXSARGS;
7766f137
GS		 4009 /* Make the host for current directory */
4010 char* ptr = PerlEnv_get_childdir();
3fadfdf1
NIS		 4011 /*
4012 * If ptr != Nullch
4013 * then it worked, set PV valid,
4014 * else return 'undef'
ad2e33dc 4015 */
7766f137
GS		 4016 if (ptr) {
4017 SV *sv = sv_newmortal();
4018 sv_setpv(sv, ptr);
4019 PerlEnv_free_childdir(ptr);
4020
617e632e
NK		 4021#ifndef INCOMPLETE_TAINTS
4022 SvTAINTED_on(sv);
4023#endif
4024
7766f137 4025 EXTEND(SP,1);
ad2e33dc 4026 SvPOK_on(sv);
bb897dfc
JD		 4027 ST(0) = sv;
4028 XSRETURN(1);
4029 }
3467312b 4030 XSRETURN_UNDEF;
ad2e33dc
GS		 4031}
4032
4033static
4034XS(w32_SetCwd)
4035{
4036 dXSARGS;
4037 if (items != 1)
4f63d024 4038 Perl_croak(aTHX_ "usage: Win32::SetCurrentDirectory($cwd)");
7766f137 4039 if (!PerlDir_chdir(SvPV_nolen(ST(0))))
ad2e33dc
GS		 4040 XSRETURN_YES;
4041
4042 XSRETURN_NO;
4043}
4044
4045static
4046XS(w32_GetNextAvailDrive)
4047{
4048 dXSARGS;
4049 char ix = 'C';
4050 char root[] = "_:\\";
3467312b
JD		 4051
4052 EXTEND(SP,1);
ad2e33dc
GS		 4053 while (ix <= 'Z') {
4054 root[0] = ix++;
4055 if (GetDriveType(root) == 1) {
4056 root[2] = '\0';
4057 XSRETURN_PV(root);
4058 }
4059 }
3467312b 4060 XSRETURN_UNDEF;
ad2e33dc
GS		 4061}
4062
4063static
4064XS(w32_GetLastError)
4065{
4066 dXSARGS;
bb897dfc 4067 EXTEND(SP,1);
ad2e33dc
GS		 4068 XSRETURN_IV(GetLastError());
4069}
4070
4071static
ca135624
JD		 4072XS(w32_SetLastError)
4073{
4074 dXSARGS;
4075 if (items != 1)
4f63d024 4076 Perl_croak(aTHX_ "usage: Win32::SetLastError($error)");
ca135624 4077 SetLastError(SvIV(ST(0)));
bb897dfc 4078 XSRETURN_EMPTY;
ca135624
JD		 4079}
4080
4081static
ad2e33dc
GS		 4082XS(w32_LoginName)
4083{
4084 dXSARGS;
3352bfcb
GS		 4085 char *name = w32_getlogin_buffer;
4086 DWORD size = sizeof(w32_getlogin_buffer);
3467312b 4087 EXTEND(SP,1);
ad2e33dc
GS		 4088 if (GetUserName(name,&size)) {
4089 /* size includes NULL */
79cb57f6 4090 ST(0) = sv_2mortal(newSVpvn(name,size-1));
ad2e33dc
GS		 4091 XSRETURN(1);
4092 }
3467312b 4093 XSRETURN_UNDEF;
ad2e33dc
GS		 4094}
4095
4096static
4097XS(w32_NodeName)
4098{
4099 dXSARGS;
4100 char name[MAX_COMPUTERNAME_LENGTH+1];
4101 DWORD size = sizeof(name);
3467312b 4102 EXTEND(SP,1);
ad2e33dc
GS		 4103 if (GetComputerName(name,&size)) {
4104 /* size does NOT include NULL :-( */
79cb57f6 4105 ST(0) = sv_2mortal(newSVpvn(name,size));
ad2e33dc
GS		 4106 XSRETURN(1);
4107 }
3467312b 4108 XSRETURN_UNDEF;
ad2e33dc
GS		 4109}
4110
4111
4112static
4113XS(w32_DomainName)
4114{
4115 dXSARGS;
da147683
JD		 4116 HINSTANCE hNetApi32 = LoadLibrary("netapi32.dll");
4117 DWORD (__stdcall *pfnNetApiBufferFree)(LPVOID Buffer);
4118 DWORD (__stdcall *pfnNetWkstaGetInfo)(LPWSTR servername, DWORD level,
4119 void *bufptr);
625a29bd 4120
da147683
JD		 4121 if (hNetApi32) {
4122 pfnNetApiBufferFree = (DWORD (__stdcall *)(void *))
4123 GetProcAddress(hNetApi32, "NetApiBufferFree");
4124 pfnNetWkstaGetInfo = (DWORD (__stdcall *)(LPWSTR, DWORD, void *))
4125 GetProcAddress(hNetApi32, "NetWkstaGetInfo");
d12db45c 4126 }
da147683
JD		 4127 EXTEND(SP,1);
4128 if (hNetApi32 && pfnNetWkstaGetInfo && pfnNetApiBufferFree) {
4129 /* this way is more reliable, in case user has a local account. */
4130 char dname[256];
4131 DWORD dnamelen = sizeof(dname);
4132 struct {
4133 DWORD wki100_platform_id;
4134 LPWSTR wki100_computername;
4135 LPWSTR wki100_langroup;
4136 DWORD wki100_ver_major;
4137 DWORD wki100_ver_minor;
4138 } *pwi;
4139 /* NERR_Success *is* 0*/
4140 if (0 == pfnNetWkstaGetInfo(NULL, 100, &pwi)) {
4141 if (pwi->wki100_langroup && *(pwi->wki100_langroup)) {
4142 WideCharToMultiByte(CP_ACP, NULL, pwi->wki100_langroup,
4143 -1, (LPSTR)dname, dnamelen, NULL, NULL);
4144 }
4145 else {
4146 WideCharToMultiByte(CP_ACP, NULL, pwi->wki100_computername,
4147 -1, (LPSTR)dname, dnamelen, NULL, NULL);
4148 }
4149 pfnNetApiBufferFree(pwi);
4150 FreeLibrary(hNetApi32);
4151 XSRETURN_PV(dname);
4152 }
4153 FreeLibrary(hNetApi32);
ad2e33dc 4154 }
625a29bd 4155 else {
da147683
JD		 4156 /* Win95 doesn't have NetWksta*(), so do it the old way */
4157 char name[256];
4158 DWORD size = sizeof(name);
4159 if (hNetApi32)
4160 FreeLibrary(hNetApi32);
4161 if (GetUserName(name,&size)) {
4162 char sid[ONE_K_BUFSIZE];
4163 DWORD sidlen = sizeof(sid);
4164 char dname[256];
4165 DWORD dnamelen = sizeof(dname);
4166 SID_NAME_USE snu;
4167 if (LookupAccountName(NULL, name, (PSID)&sid, &sidlen,
4168 dname, &dnamelen, &snu)) {
4169 XSRETURN_PV(dname); /* all that for this */
4170 }
4171 }
9404a519 4172 }
da147683 4173 XSRETURN_UNDEF;
ad2e33dc
GS		 4174}
4175
4176static
4177XS(w32_FsType)
4178{
4179 dXSARGS;
4180 char fsname[256];
4181 DWORD flags, filecomplen;
4182 if (GetVolumeInformation(NULL, NULL, 0, NULL, &filecomplen,
4183 &flags, fsname, sizeof(fsname))) {
bb897dfc 4184 if (GIMME_V == G_ARRAY) {
79cb57f6 4185 XPUSHs(sv_2mortal(newSVpvn(fsname,strlen(fsname))));
ad2e33dc
GS		 4186 XPUSHs(sv_2mortal(newSViv(flags)));
4187 XPUSHs(sv_2mortal(newSViv(filecomplen)));
4188 PUTBACK;
4189 return;
4190 }
bb897dfc 4191 EXTEND(SP,1);
ad2e33dc
GS		 4192 XSRETURN_PV(fsname);
4193 }
bb897dfc 4194 XSRETURN_EMPTY;
ad2e33dc
GS		 4195}
4196
4197static
4198XS(w32_GetOSVersion)
4199{
4200 dXSARGS;
7766f137 4201 OSVERSIONINFOA osver;
ad2e33dc 4202
7766f137
GS		 4203 if (USING_WIDE()) {
4204 OSVERSIONINFOW osverw;
4205 char szCSDVersion[sizeof(osverw.szCSDVersion)];
4206 osverw.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW);
4207 if (!GetVersionExW(&osverw)) {
4208 XSRETURN_EMPTY;
4209 }
4210 W2AHELPER(osverw.szCSDVersion, szCSDVersion, sizeof(szCSDVersion));
4211 XPUSHs(newSVpvn(szCSDVersion, strlen(szCSDVersion)));
4212 osver.dwMajorVersion = osverw.dwMajorVersion;
4213 osver.dwMinorVersion = osverw.dwMinorVersion;
4214 osver.dwBuildNumber = osverw.dwBuildNumber;
4215 osver.dwPlatformId = osverw.dwPlatformId;
4216 }
4217 else {
4218 osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFOA);
4219 if (!GetVersionExA(&osver)) {
4220 XSRETURN_EMPTY;
4221 }
79cb57f6 4222 XPUSHs(newSVpvn(osver.szCSDVersion, strlen(osver.szCSDVersion)));
ad2e33dc 4223 }
7766f137
GS		 4224 XPUSHs(newSViv(osver.dwMajorVersion));
4225 XPUSHs(newSViv(osver.dwMinorVersion));
4226 XPUSHs(newSViv(osver.dwBuildNumber));
4227 XPUSHs(newSViv(osver.dwPlatformId));
4228 PUTBACK;
ad2e33dc
GS		 4229}
4230
4231static
4232XS(w32_IsWinNT)
4233{
4234 dXSARGS;
bb897dfc 4235 EXTEND(SP,1);
ad2e33dc
GS		 4236 XSRETURN_IV(IsWinNT());
4237}
4238
4239static
4240XS(w32_IsWin95)
4241{
4242 dXSARGS;
bb897dfc 4243 EXTEND(SP,1);
ad2e33dc
GS		 4244 XSRETURN_IV(IsWin95());
4245}
4246
4247static
4248XS(w32_FormatMessage)
4249{
4250 dXSARGS;
4251 DWORD source = 0;
7766f137 4252 char msgbuf[ONE_K_BUFSIZE];
ad2e33dc
GS		 4253
4254 if (items != 1)
4f63d024 4255 Perl_croak(aTHX_ "usage: Win32::FormatMessage($errno)");
ad2e33dc 4256
7766f137
GS		 4257 if (USING_WIDE()) {
4258 WCHAR wmsgbuf[ONE_K_BUFSIZE];
4259 if (FormatMessageW(FORMAT_MESSAGE_FROM_SYSTEM,
4260 &source, SvIV(ST(0)), 0,
4261 wmsgbuf, ONE_K_BUFSIZE-1, NULL))
4262 {
4263 W2AHELPER(wmsgbuf, msgbuf, sizeof(msgbuf));
4264 XSRETURN_PV(msgbuf);
4265 }
4266 }
4267 else {
4268 if (FormatMessageA(FORMAT_MESSAGE_FROM_SYSTEM,
4269 &source, SvIV(ST(0)), 0,
4270 msgbuf, sizeof(msgbuf)-1, NULL))
4271 XSRETURN_PV(msgbuf);
4272 }
ad2e33dc 4273
3467312b 4274 XSRETURN_UNDEF;
ad2e33dc
GS		 4275}
4276
4277static
4278XS(w32_Spawn)
4279{
4280 dXSARGS;
4281 char *cmd, *args;
33005217
JD		 4282 void *env;
4283 char *dir;
ad2e33dc
GS		 4284 PROCESS_INFORMATION stProcInfo;
4285 STARTUPINFO stStartInfo;
4286 BOOL bSuccess = FALSE;
4287
9404a519 4288 if (items != 3)
4f63d024 4289 Perl_croak(aTHX_ "usage: Win32::Spawn($cmdName, $args, $PID)");
ad2e33dc 4290
bb897dfc
JD		 4291 cmd = SvPV_nolen(ST(0));
4292 args = SvPV_nolen(ST(1));
ad2e33dc 4293
33005217
JD		 4294 env = PerlEnv_get_childenv();
4295 dir = PerlEnv_get_childdir();
4296
ad2e33dc
GS		 4297 memset(&stStartInfo, 0, sizeof(stStartInfo)); /* Clear the block */
4298 stStartInfo.cb = sizeof(stStartInfo); /* Set the structure size */
4299 stStartInfo.dwFlags = STARTF_USESHOWWINDOW; /* Enable wShowWindow control */
4300 stStartInfo.wShowWindow = SW_SHOWMINNOACTIVE; /* Start min (normal) */
4301
9404a519 4302 if (CreateProcess(
ad2e33dc
GS		 4303 cmd, /* Image path */
4304 args, /* Arguments for command line */
4305 NULL, /* Default process security */
4306 NULL, /* Default thread security */
4307 FALSE, /* Must be TRUE to use std handles */
4308 NORMAL_PRIORITY_CLASS, /* No special scheduling */
33005217
JD		 4309 env, /* Inherit our environment block */
4310 dir, /* Inherit our currrent directory */
ad2e33dc
GS		 4311 &stStartInfo, /* -> Startup info */
4312 &stProcInfo)) /* <- Process info (if OK) */
4313 {
922b1888
GS		 4314 int pid = (int)stProcInfo.dwProcessId;
4315 if (IsWin95() && pid < 0)
4316 pid = -pid;
4317 sv_setiv(ST(2), pid);
ad2e33dc 4318 CloseHandle(stProcInfo.hThread);/* library source code does this. */
ad2e33dc
GS		 4319 bSuccess = TRUE;
4320 }
33005217
JD		 4321 PerlEnv_free_childenv(env);
4322 PerlEnv_free_childdir(dir);
ad2e33dc
GS		 4323 XSRETURN_IV(bSuccess);
4324}
4325
4326static
4327XS(w32_GetTickCount)
4328{
4329 dXSARGS;
fdb068fa 4330 DWORD msec = GetTickCount();
a6c40364 4331 EXTEND(SP,1);
fdb068fa
JD		 4332 if ((IV)msec > 0)
4333 XSRETURN_IV(msec);
4334 XSRETURN_NV(msec);
ad2e33dc
GS		 4335}
4336
4337static
4338XS(w32_GetShortPathName)
4339{
4340 dXSARGS;
4341 SV *shortpath;
e8bab181 4342 DWORD len;
ad2e33dc 4343
9404a519 4344 if (items != 1)
4f63d024 4345 Perl_croak(aTHX_ "usage: Win32::GetShortPathName($longPathName)");
ad2e33dc
GS		 4346
4347 shortpath = sv_mortalcopy(ST(0));
4348 SvUPGRADE(shortpath, SVt_PV);
631c0b04
GS		 4349 if (!SvPVX(shortpath) || !SvLEN(shortpath))
4350 XSRETURN_UNDEF;
4351
ad2e33dc 4352 /* src == target is allowed */
e8bab181
GS		 4353 do {
4354 len = GetShortPathName(SvPVX(shortpath),
4355 SvPVX(shortpath),
4356 SvLEN(shortpath));
4357 } while (len >= SvLEN(shortpath) && sv_grow(shortpath,len+1));
4358 if (len) {
4359 SvCUR_set(shortpath,len);
ad2e33dc 4360 ST(0) = shortpath;
bb897dfc 4361 XSRETURN(1);
e8bab181 4362 }
3467312b 4363 XSRETURN_UNDEF;
ad2e33dc
GS		 4364}
4365
ad0751ec 4366static
ca135624
JD		 4367XS(w32_GetFullPathName)
4368{
4369 dXSARGS;
4370 SV *filename;
4371 SV *fullpath;
4372 char *filepart;
4373 DWORD len;
4374
4375 if (items != 1)
4f63d024 4376 Perl_croak(aTHX_ "usage: Win32::GetFullPathName($filename)");
ca135624
JD		 4377
4378 filename = ST(0);
4379 fullpath = sv_mortalcopy(filename);
4380 SvUPGRADE(fullpath, SVt_PV);
631c0b04
GS		 4381 if (!SvPVX(fullpath) || !SvLEN(fullpath))
4382 XSRETURN_UNDEF;
4383
ca135624
JD		 4384 do {
4385 len = GetFullPathName(SvPVX(filename),
4386 SvLEN(fullpath),
4387 SvPVX(fullpath),
4388 &filepart);
4389 } while (len >= SvLEN(fullpath) && sv_grow(fullpath,len+1));
4390 if (len) {
4391 if (GIMME_V == G_ARRAY) {
4392 EXTEND(SP,1);
bb897dfc 4393 XST_mPV(1,filepart);
ca135624
JD		 4394 len = filepart - SvPVX(fullpath);
4395 items = 2;
4396 }
4397 SvCUR_set(fullpath,len);
4398 ST(0) = fullpath;
bb897dfc 4399 XSRETURN(items);
ca135624 4400 }
bb897dfc 4401 XSRETURN_EMPTY;
ca135624
JD		 4402}
4403
4404static
8ac9c18d
GS		 4405XS(w32_GetLongPathName)
4406{
4407 dXSARGS;
4408 SV *path;
4409 char tmpbuf[MAX_PATH+1];
4410 char *pathstr;
4411 STRLEN len;
4412
4413 if (items != 1)
4f63d024 4414 Perl_croak(aTHX_ "usage: Win32::GetLongPathName($pathname)");
8ac9c18d
GS		 4415
4416 path = ST(0);
4417 pathstr = SvPV(path,len);
4418 strcpy(tmpbuf, pathstr);
4419 pathstr = win32_longpath(tmpbuf);
4420 if (pathstr) {
4421 ST(0) = sv_2mortal(newSVpvn(pathstr, strlen(pathstr)));
4422 XSRETURN(1);
4423 }
4424 XSRETURN_EMPTY;
4425}
4426
4427static
ad0751ec
GS		 4428XS(w32_Sleep)
4429{
4430 dXSARGS;
4431 if (items != 1)
4f63d024 4432 Perl_croak(aTHX_ "usage: Win32::Sleep($milliseconds)");
ad0751ec
GS		 4433 Sleep(SvIV(ST(0)));
4434 XSRETURN_YES;
4435}
4436
7509b657
GS		 4437static
4438XS(w32_CopyFile)
4439{
4440 dXSARGS;
7766f137 4441 BOOL bResult;
7509b657 4442 if (items != 3)
4f63d024 4443 Perl_croak(aTHX_ "usage: Win32::CopyFile($from, $to, $overwrite)");
7766f137 4444 if (USING_WIDE()) {
82867ecf
GS		 4445 WCHAR wSourceFile[MAX_PATH+1];
4446 WCHAR wDestFile[MAX_PATH+1];
7766f137
GS		 4447 A2WHELPER(SvPV_nolen(ST(0)), wSourceFile, sizeof(wSourceFile));
4448 wcscpy(wSourceFile, PerlDir_mapW(wSourceFile));
4449 A2WHELPER(SvPV_nolen(ST(1)), wDestFile, sizeof(wDestFile));
4450 bResult = CopyFileW(wSourceFile, PerlDir_mapW(wDestFile), !SvTRUE(ST(2)));
4451 }
4452 else {
82867ecf 4453 char szSourceFile[MAX_PATH+1];
7766f137
GS		 4454 strcpy(szSourceFile, PerlDir_mapA(SvPV_nolen(ST(0))));
4455 bResult = CopyFileA(szSourceFile, PerlDir_mapA(SvPV_nolen(ST(1))), !SvTRUE(ST(2)));
4456 }
4457
4458 if (bResult)
7509b657
GS		 4459 XSRETURN_YES;
4460 XSRETURN_NO;
4461}
4462
ad2e33dc 4463void
c5be433b 4464Perl_init_os_extras(void)
ad2e33dc 4465{
acfe0abc 4466 dTHX;
ad2e33dc
GS		 4467 char *file = __FILE__;
4468 dXSUB_SYS;
4469
ad2e33dc
GS		 4470 /* these names are Activeware compatible */
4471 newXS("Win32::GetCwd", w32_GetCwd, file);
4472 newXS("Win32::SetCwd", w32_SetCwd, file);
4473 newXS("Win32::GetNextAvailDrive", w32_GetNextAvailDrive, file);
4474 newXS("Win32::GetLastError", w32_GetLastError, file);
ca135624 4475 newXS("Win32::SetLastError", w32_SetLastError, file);
ad2e33dc
GS		 4476 newXS("Win32::LoginName", w32_LoginName, file);
4477 newXS("Win32::NodeName", w32_NodeName, file);
4478 newXS("Win32::DomainName", w32_DomainName, file);
4479 newXS("Win32::FsType", w32_FsType, file);
4480 newXS("Win32::GetOSVersion", w32_GetOSVersion, file);
4481 newXS("Win32::IsWinNT", w32_IsWinNT, file);
4482 newXS("Win32::IsWin95", w32_IsWin95, file);
4483 newXS("Win32::FormatMessage", w32_FormatMessage, file);
4484 newXS("Win32::Spawn", w32_Spawn, file);
4485 newXS("Win32::GetTickCount", w32_GetTickCount, file);
4486 newXS("Win32::GetShortPathName", w32_GetShortPathName, file);
ca135624 4487 newXS("Win32::GetFullPathName", w32_GetFullPathName, file);
8ac9c18d 4488 newXS("Win32::GetLongPathName", w32_GetLongPathName, file);
7509b657 4489 newXS("Win32::CopyFile", w32_CopyFile, file);
ad0751ec 4490 newXS("Win32::Sleep", w32_Sleep, file);
ad2e33dc
GS		 4491
4492 /* XXX Bloat Alert! The following Activeware preloads really
4493 * ought to be part of Win32::Sys::*, so they're not included
4494 * here.
4495 */
4496 /* LookupAccountName
4497 * LookupAccountSID
4498 * InitiateSystemShutdown
4499 * AbortSystemShutdown
4500 * ExpandEnvrironmentStrings
4501 */
4502}
4503
1018e26f
NIS		 4504PerlInterpreter *
4505win32_signal_context(void)
c843839f
NIS		 4506{
4507 dTHX;
4508 if (!my_perl) {
1018e26f 4509 my_perl = PL_curinterp;
c843839f 4510 PERL_SET_THX(my_perl);
3fadfdf1 4511 }
1018e26f
NIS		 4512 return my_perl;
4513}
4514
3fadfdf1 4515BOOL WINAPI
1018e26f
NIS		 4516win32_ctrlhandler(DWORD dwCtrlType)
4517{
4518 dTHXa(PERL_GET_SIG_CONTEXT);
4519
4520 if (!my_perl)
4521 return FALSE;
c843839f
NIS		 4522
4523 switch(dwCtrlType) {
4524 case CTRL_CLOSE_EVENT:
3fadfdf1
NIS		 4525 /* A signal that the system sends to all processes attached to a console when
4526 the user closes the console (either by choosing the Close command from the
4527 console window's System menu, or by choosing the End Task command from the
c843839f
NIS		 4528 Task List
4529 */
3fadfdf1
NIS		 4530 if (do_raise(aTHX_ 1)) /* SIGHUP */
4531 sig_terminate(aTHX_ 1);
4532 return TRUE;
c843839f
NIS		 4533
4534 case CTRL_C_EVENT:
4535 /* A CTRL+c signal was received */
3fadfdf1
NIS		 4536 if (do_raise(aTHX_ SIGINT))
4537 sig_terminate(aTHX_ SIGINT);
4538 return TRUE;
c843839f
NIS		 4539
4540 case CTRL_BREAK_EVENT:
4541 /* A CTRL+BREAK signal was received */
3fadfdf1
NIS		 4542 if (do_raise(aTHX_ SIGBREAK))
4543 sig_terminate(aTHX_ SIGBREAK);
4544 return TRUE;
c843839f
NIS		 4545
4546 case CTRL_LOGOFF_EVENT:
3fadfdf1
NIS		 4547 /* A signal that the system sends to all console processes when a user is logging
4548 off. This signal does not indicate which user is logging off, so no
4549 assumptions can be made.
c843839f 4550 */
3fadfdf1 4551 break;
c843839f 4552 case CTRL_SHUTDOWN_EVENT:
3fadfdf1
NIS		 4553 /* A signal that the system sends to all console processes when the system is
4554 shutting down.
c843839f 4555 */
3fadfdf1
NIS		 4556 if (do_raise(aTHX_ SIGTERM))
4557 sig_terminate(aTHX_ SIGTERM);
4558 return TRUE;
c843839f 4559 default:
3fadfdf1 4560 break;
c843839f
NIS		 4561 }
4562 return FALSE;
4563}
c843839f
NIS		 4564
4565
ad2e33dc
GS		 4566void
4567Perl_win32_init(int *argcp, char ***argvp)
4568{
4569 /* Disable floating point errors, Perl will trap the ones we
4570 * care about. VC++ RTL defaults to switching these off
4571 * already, but the Borland RTL doesn't. Since we don't
4572 * want to be at the vendor's whim on the default, we set
4573 * it explicitly here.
4574 */
a835ef8a 4575#if !defined(_ALPHA_) && !defined(__GNUC__)
ad2e33dc 4576 _control87(MCW_EM, MCW_EM);
3dc9191e 4577#endif
4b556e6c 4578 MALLOC_INIT;
ad2e33dc 4579}
d55594ae 4580
635bbe87
GS		 4581void
4582win32_get_child_IO(child_IO_table* ptbl)
4583{
4584 ptbl->childStdIn = GetStdHandle(STD_INPUT_HANDLE);
4585 ptbl->childStdOut = GetStdHandle(STD_OUTPUT_HANDLE);
4586 ptbl->childStdErr = GetStdHandle(STD_ERROR_HANDLE);
4587}
4588
3fadfdf1
NIS		 4589Sighandler_t
4590win32_signal(int sig, Sighandler_t subcode)
4591{
4592 dTHX;
4593 if (sig < SIG_SIZE) {
4594 int save_errno = errno;
4595 Sighandler_t result = signal(sig, subcode);
4596 if (result == SIG_ERR) {
4597 result = w32_sighandler[sig];
4598 errno = save_errno;
4599 }
4600 w32_sighandler[sig] = subcode;
4601 return result;
4602 }
4603 else {
4604 errno = EINVAL;
4605 return SIG_ERR;
4606 }
4607}
4608
4609
52853b95 4610#ifdef HAVE_INTERP_INTERN
7766f137 4611
c843839f 4612
f646a69a
NIS		 4613static void
4614win32_csighandler(int sig)
4615{
4616#if 0
4617 dTHXa(PERL_GET_SIG_CONTEXT);
4618 Perl_warn(aTHX_ "Got signal %d",sig);
4619#endif
4620 /* Does nothing */
4621}
c843839f 4622
7766f137 4623void
52853b95
GS		 4624Perl_sys_intern_init(pTHX)
4625{
3fadfdf1 4626 int i;
52853b95
GS		 4627 w32_perlshell_tokens = Nullch;
4628 w32_perlshell_vec = (char**)NULL;
4629 w32_perlshell_items = 0;
4630 w32_fdpid = newAV();
4631 New(1313, w32_children, 1, child_tab);
4632 w32_num_children = 0;
4633# ifdef USE_ITHREADS
4634 w32_pseudo_id = 0;
4635 New(1313, w32_pseudo_children, 1, child_tab);
4636 w32_num_pseudo_children = 0;
4637# endif
4638 w32_init_socktype = 0;
222c300a 4639 w32_timerid = 0;
05ec9bb3 4640 w32_poll_count = 0;
3fadfdf1
NIS		 4641 for (i=0; i < SIG_SIZE; i++) {
4642 w32_sighandler[i] = SIG_DFL;
4643 }
1018e26f 4644 if (my_perl == PL_curinterp) {
3fadfdf1 4645 /* Force C runtime signal stuff to set its console handler */
f646a69a
NIS		 4646 signal(SIGINT,&win32_csighandler);
4647 signal(SIGBREAK,&win32_csighandler);
3fadfdf1 4648 /* Push our handler on top */
c843839f
NIS		 4649 SetConsoleCtrlHandler(win32_ctrlhandler,TRUE);
4650 }
52853b95
GS		 4651}
4652
3dbbd0f5
GS		 4653void
4654Perl_sys_intern_clear(pTHX)
4655{
4656 Safefree(w32_perlshell_tokens);
4657 Safefree(w32_perlshell_vec);
4658 /* NOTE: w32_fdpid is freed by sv_clean_all() */
4659 Safefree(w32_children);
222c300a
NIS		 4660 if (w32_timerid) {
4661 KillTimer(NULL,w32_timerid);
3fadfdf1 4662 w32_timerid=0;
222c300a 4663 }
1018e26f 4664 if (my_perl == PL_curinterp) {
c843839f 4665 SetConsoleCtrlHandler(win32_ctrlhandler,FALSE);
c843839f 4666 }
3dbbd0f5
GS		 4667# ifdef USE_ITHREADS
4668 Safefree(w32_pseudo_children);
4669# endif
4670}
4671
52853b95
GS		 4672# ifdef USE_ITHREADS
4673
4674void
7766f137
GS		 4675Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst)
4676{
4677 dst->perlshell_tokens = Nullch;
4678 dst->perlshell_vec = (char**)NULL;
4679 dst->perlshell_items = 0;
4680 dst->fdpid = newAV();
4681 Newz(1313, dst->children, 1, child_tab);
7766f137 4682 dst->pseudo_id = 0;
52853b95 4683 Newz(1313, dst->pseudo_children, 1, child_tab);
862f1e8c 4684 dst->thr_intern.Winit_socktype = 0;
222c300a 4685 dst->timerid = 0;
05ec9bb3 4686 dst->poll_count = 0;
3fadfdf1 4687 Copy(src->sigtable,dst->sigtable,SIG_SIZE,Sighandler_t);
7766f137 4688}
52853b95
GS		 4689# endif /* USE_ITHREADS */
4690#endif /* HAVE_INTERP_INTERN */
7766f137 4691
729a02f2 4692static void
acfe0abc 4693win32_free_argvw(pTHX_ void *ptr)
729a02f2
GS		 4694{
4695 char** argv = (char**)ptr;
4696 while(*argv) {
4697 Safefree(*argv);
4698 *argv++ = Nullch;
4699 }
4700}
4701
4702void
c0932edc 4703win32_argv2utf8(int argc, char** argv)
729a02f2 4704{
acfe0abc 4705 dTHX;
729a02f2
GS		 4706 char* psz;
4707 int length, wargc;
4708 LPWSTR* lpwStr = CommandLineToArgvW(GetCommandLineW(), &wargc);
4709 if (lpwStr && argc) {
4710 while (argc--) {
4711 length = WideCharToMultiByte(CP_UTF8, 0, lpwStr[--wargc], -1, NULL, 0, NULL, NULL);
4712 Newz(0, psz, length, char);
4713 WideCharToMultiByte(CP_UTF8, 0, lpwStr[wargc], -1, psz, length, NULL, NULL);
4714 argv[argc] = psz;
4715 }
4716 call_atexit(win32_free_argvw, argv);
4717 }
4718 GlobalFree((HGLOBAL)lpwStr);
4719}
Unnamed repository; edit this file 'description' to name the repository.