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